{-# LANGUAGE CPP #-}
module KMonad.Args.Joiner
( joinConfigIO
, joinConfig
)
where
import KMonad.Prelude hiding (uncons)
import KMonad.Args.Types
import KMonad.Action
import KMonad.Button
import KMonad.Keyboard
import KMonad.Keyboard.IO
#ifdef linux_HOST_OS
import KMonad.Keyboard.IO.Linux.DeviceSource
import KMonad.Keyboard.IO.Linux.UinputSink
#endif
#ifdef mingw32_HOST_OS
import KMonad.Keyboard.IO.Windows.LowLevelHookSource
import KMonad.Keyboard.IO.Windows.SendEventSink
#endif
#ifdef darwin_HOST_OS
import KMonad.Keyboard.IO.Mac.IOKitSource
import KMonad.Keyboard.IO.Mac.KextSink
#endif
import Control.Monad.Except
import RIO.List (uncons, headMaybe)
import RIO.Partial (fromJust)
import qualified Data.LayerStack as L
import qualified RIO.HashMap as M
import qualified RIO.Text as T
data JoinError
= DuplicateBlock Text
| MissingBlock Text
| DuplicateAlias Text
| DuplicateLayer Text
| MissingAlias Text
| MissingLayer Text
| MissingSetting Text
| DuplicateSetting Text
| InvalidOS Text
| NestedTrans
| InvalidComposeKey
| LengthMismatch Text Int Int
instance Show JoinError where
show :: JoinError -> String
show e :: JoinError
e = case JoinError
e of
DuplicateBlock t :: Text
t -> "Encountered duplicate block of type: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t
MissingBlock t :: Text
t -> "Missing at least 1 block of type: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t
DuplicateAlias t :: Text
t -> "Multiple aliases of the same name: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t
DuplicateLayer t :: Text
t -> "Multiple layers of the same name: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t
MissingAlias t :: Text
t -> "Reference to non-existent alias: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t
MissingLayer t :: Text
t -> "Reference to non-existent layer: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t
MissingSetting t :: Text
t -> "Missing setting in 'defcfg': " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t
DuplicateSetting t :: Text
t -> "Duplicate setting in 'defcfg': " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t
InvalidOS t :: Text
t -> "Not available under this OS: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t
NestedTrans -> "Encountered 'Transparent' ouside of top-level layer"
InvalidComposeKey -> "Encountered invalid button as Compose key"
LengthMismatch t :: Text
t l :: Int
l s :: Int
s -> [String] -> String
forall a. Monoid a => [a] -> a
mconcat
[ "Mismatch between length of 'defsrc' and deflayer <", Text -> String
T.unpack Text
t, ">\n"
, "Source length: ", Int -> String
forall a. Show a => a -> String
show Int
s, "\n"
, "Layer length: ", Int -> String
forall a. Show a => a -> String
show Int
l ]
instance Exception JoinError
data JCfg = JCfg
{ JCfg -> Button
_cmpKey :: Button
, JCfg -> [KExpr]
_kes :: [KExpr]
}
makeLenses ''JCfg
defJCfg :: [KExpr] ->JCfg
defJCfg :: [KExpr] -> JCfg
defJCfg = Button -> [KExpr] -> JCfg
JCfg
(Keycode -> Button
emitB Keycode
KeyRightAlt)
newtype J a = J { J a -> ExceptT JoinError (Reader JCfg) a
unJ :: ExceptT JoinError (Reader JCfg) a }
deriving ( a -> J b -> J a
(a -> b) -> J a -> J b
(forall a b. (a -> b) -> J a -> J b)
-> (forall a b. a -> J b -> J a) -> Functor J
forall a b. a -> J b -> J a
forall a b. (a -> b) -> J a -> J b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> J b -> J a
$c<$ :: forall a b. a -> J b -> J a
fmap :: (a -> b) -> J a -> J b
$cfmap :: forall a b. (a -> b) -> J a -> J b
Functor, Functor J
a -> J a
Functor J =>
(forall a. a -> J a)
-> (forall a b. J (a -> b) -> J a -> J b)
-> (forall a b c. (a -> b -> c) -> J a -> J b -> J c)
-> (forall a b. J a -> J b -> J b)
-> (forall a b. J a -> J b -> J a)
-> Applicative J
J a -> J b -> J b
J a -> J b -> J a
J (a -> b) -> J a -> J b
(a -> b -> c) -> J a -> J b -> J c
forall a. a -> J a
forall a b. J a -> J b -> J a
forall a b. J a -> J b -> J b
forall a b. J (a -> b) -> J a -> J b
forall a b c. (a -> b -> c) -> J a -> J b -> J c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: J a -> J b -> J a
$c<* :: forall a b. J a -> J b -> J a
*> :: J a -> J b -> J b
$c*> :: forall a b. J a -> J b -> J b
liftA2 :: (a -> b -> c) -> J a -> J b -> J c
$cliftA2 :: forall a b c. (a -> b -> c) -> J a -> J b -> J c
<*> :: J (a -> b) -> J a -> J b
$c<*> :: forall a b. J (a -> b) -> J a -> J b
pure :: a -> J a
$cpure :: forall a. a -> J a
$cp1Applicative :: Functor J
Applicative, Applicative J
a -> J a
Applicative J =>
(forall a b. J a -> (a -> J b) -> J b)
-> (forall a b. J a -> J b -> J b)
-> (forall a. a -> J a)
-> Monad J
J a -> (a -> J b) -> J b
J a -> J b -> J b
forall a. a -> J a
forall a b. J a -> J b -> J b
forall a b. J a -> (a -> J b) -> J b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> J a
$creturn :: forall a. a -> J a
>> :: J a -> J b -> J b
$c>> :: forall a b. J a -> J b -> J b
>>= :: J a -> (a -> J b) -> J b
$c>>= :: forall a b. J a -> (a -> J b) -> J b
$cp1Monad :: Applicative J
Monad
, MonadError JoinError , MonadReader JCfg)
runJ :: J a -> JCfg -> Either JoinError a
runJ :: J a -> JCfg -> Either JoinError a
runJ j :: J a
j = Reader JCfg (Either JoinError a) -> JCfg -> Either JoinError a
forall r a. Reader r a -> r -> a
runReader (ExceptT JoinError (Reader JCfg) a
-> Reader JCfg (Either JoinError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT JoinError (Reader JCfg) a
-> Reader JCfg (Either JoinError a))
-> ExceptT JoinError (Reader JCfg) a
-> Reader JCfg (Either JoinError a)
forall a b. (a -> b) -> a -> b
$ J a -> ExceptT JoinError (Reader JCfg) a
forall a. J a -> ExceptT JoinError (Reader JCfg) a
unJ J a
j)
joinConfigIO :: HasLogFunc e => [KExpr] -> RIO e CfgToken
joinConfigIO :: [KExpr] -> RIO e CfgToken
joinConfigIO es :: [KExpr]
es = case J CfgToken -> JCfg -> Either JoinError CfgToken
forall a. J a -> JCfg -> Either JoinError a
runJ J CfgToken
joinConfig (JCfg -> Either JoinError CfgToken)
-> JCfg -> Either JoinError CfgToken
forall a b. (a -> b) -> a -> b
$ [KExpr] -> JCfg
defJCfg [KExpr]
es of
Left e :: JoinError
e -> JoinError -> RIO e CfgToken
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM JoinError
e
Right c :: CfgToken
c -> CfgToken -> RIO e CfgToken
forall (f :: * -> *) a. Applicative f => a -> f a
pure CfgToken
c
extract :: Prism' a b -> [a] -> [b]
p :: Prism' a b
p = [Maybe b] -> [b]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe b] -> [b]) -> ([a] -> [Maybe b]) -> [a] -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe b) -> [a] -> [Maybe b]
forall a b. (a -> b) -> [a] -> [b]
map (Getting (First b) a b -> a -> Maybe b
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting (First b) a b
Prism' a b
p)
data SingletonError
= None
| Duplicate
onlyOne :: [a] -> Either SingletonError a
onlyOne :: [a] -> Either SingletonError a
onlyOne xs :: [a]
xs = case [a] -> Maybe (a, [a])
forall a. [a] -> Maybe (a, [a])
uncons [a]
xs of
Just (x :: a
x, []) -> a -> Either SingletonError a
forall a b. b -> Either a b
Right a
x
Just _ -> SingletonError -> Either SingletonError a
forall a b. a -> Either a b
Left SingletonError
Duplicate
Nothing -> SingletonError -> Either SingletonError a
forall a b. a -> Either a b
Left SingletonError
None
oneBlock :: Text -> Prism' KExpr a -> J a
oneBlock :: Text -> Prism' KExpr a -> J a
oneBlock t :: Text
t l :: Prism' KExpr a
l = [a] -> Either SingletonError a
forall a. [a] -> Either SingletonError a
onlyOne ([a] -> Either SingletonError a)
-> ([KExpr] -> [a]) -> [KExpr] -> Either SingletonError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' KExpr a -> [KExpr] -> [a]
forall a b. Prism' a b -> [a] -> [b]
extract Prism' KExpr a
l ([KExpr] -> Either SingletonError a)
-> J [KExpr] -> J (Either SingletonError a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting [KExpr] JCfg [KExpr] -> J [KExpr]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [KExpr] JCfg [KExpr]
Lens' JCfg [KExpr]
kes J (Either SingletonError a)
-> (Either SingletonError a -> J a) -> J a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Right x :: a
x -> a -> J a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
Left None -> JoinError -> J a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> J a) -> JoinError -> J a
forall a b. (a -> b) -> a -> b
$ Text -> JoinError
MissingBlock Text
t
Left Duplicate -> JoinError -> J a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> J a) -> JoinError -> J a
forall a b. (a -> b) -> a -> b
$ Text -> JoinError
DuplicateBlock Text
t
joinConfig :: J CfgToken
joinConfig :: J CfgToken
joinConfig = J JCfg
getOverride J JCfg -> (JCfg -> J CfgToken) -> J CfgToken
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \cfg :: JCfg
cfg -> ((JCfg -> JCfg) -> J CfgToken -> J CfgToken
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (JCfg -> JCfg -> JCfg
forall a b. a -> b -> a
const JCfg
cfg) J CfgToken
joinConfig')
joinConfig' :: J CfgToken
joinConfig' :: J CfgToken
joinConfig' = do
[KExpr]
es <- Getting [KExpr] JCfg [KExpr] -> J [KExpr]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [KExpr] JCfg [KExpr]
Lens' JCfg [KExpr]
kes
LogFunc -> IO (Acquire KeySource)
i <- J (LogFunc -> IO (Acquire KeySource))
getI
LogFunc -> IO (Acquire KeySink)
o <- J (LogFunc -> IO (Acquire KeySink))
getO
Bool
ft <- J Bool
getFT
Bool
al <- J Bool
getAllow
let als :: [DefAlias]
als = Prism' KExpr DefAlias -> [KExpr] -> [DefAlias]
forall a b. Prism' a b -> [a] -> [b]
extract forall r. AsKExpr r => Prism' r DefAlias
Prism' KExpr DefAlias
_KDefAlias ([KExpr] -> [DefAlias]) -> [KExpr] -> [DefAlias]
forall a b. (a -> b) -> a -> b
$ [KExpr]
es
let lys :: [DefLayer]
lys = Prism' KExpr DefLayer -> [KExpr] -> [DefLayer]
forall a b. Prism' a b -> [a] -> [b]
extract forall r. AsKExpr r => Prism' r DefLayer
Prism' KExpr DefLayer
_KDefLayer ([KExpr] -> [DefLayer]) -> [KExpr] -> [DefLayer]
forall a b. (a -> b) -> a -> b
$ [KExpr]
es
DefSrc
src <- Text -> Prism' KExpr DefSrc -> J DefSrc
forall a. Text -> Prism' KExpr a -> J a
oneBlock "defsrc" forall r. AsKExpr r => Prism' r DefSrc
Prism' KExpr DefSrc
_KDefSrc
(km :: LMap Button
km, fl :: Text
fl) <- DefSrc -> [DefAlias] -> [DefLayer] -> J (LMap Button, Text)
joinKeymap DefSrc
src [DefAlias]
als [DefLayer]
lys
CfgToken -> J CfgToken
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CfgToken -> J CfgToken) -> CfgToken -> J CfgToken
forall a b. (a -> b) -> a -> b
$ CfgToken :: (LogFunc -> IO (Acquire KeySource))
-> (LogFunc -> IO (Acquire KeySink))
-> LMap Button
-> Text
-> Bool
-> Bool
-> CfgToken
CfgToken
{ _snk :: LogFunc -> IO (Acquire KeySink)
_snk = LogFunc -> IO (Acquire KeySink)
o
, _src :: LogFunc -> IO (Acquire KeySource)
_src = LogFunc -> IO (Acquire KeySource)
i
, _km :: LMap Button
_km = LMap Button
km
, _fstL :: Text
_fstL = Text
fl
, _flt :: Bool
_flt = Bool
ft
, _allow :: Bool
_allow = Bool
al
}
getOverride :: J JCfg
getOverride :: J JCfg
getOverride = do
JCfg
env <- J JCfg
forall r (m :: * -> *). MonadReader r m => m r
ask
[DefSetting]
cfg <- Text -> Prism' KExpr [DefSetting] -> J [DefSetting]
forall a. Text -> Prism' KExpr a -> J a
oneBlock "defcfg" forall r. AsKExpr r => Prism' r [DefSetting]
Prism' KExpr [DefSetting]
_KDefCfg
let getB :: DefButton -> J (Maybe Button)
getB = LNames -> Aliases -> DefButton -> J (Maybe Button)
joinButton [] Aliases
forall k v. HashMap k v
M.empty
let go :: JCfg -> DefSetting -> J JCfg
go e :: JCfg
e v :: DefSetting
v = case DefSetting
v of
SCmpSeq b :: DefButton
b -> DefButton -> J (Maybe Button)
getB DefButton
b J (Maybe Button) -> (Maybe Button -> J JCfg) -> J JCfg
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= J JCfg -> (Button -> J JCfg) -> Maybe Button -> J JCfg
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (JoinError -> J JCfg
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError JoinError
InvalidComposeKey)
(\b' :: Button
b' -> JCfg -> J JCfg
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JCfg -> J JCfg) -> JCfg -> J JCfg
forall a b. (a -> b) -> a -> b
$ ASetter JCfg JCfg Button Button -> Button -> JCfg -> JCfg
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter JCfg JCfg Button Button
Lens' JCfg Button
cmpKey Button
b' JCfg
e)
_ -> JCfg -> J JCfg
forall (f :: * -> *) a. Applicative f => a -> f a
pure JCfg
e
(JCfg -> DefSetting -> J JCfg) -> JCfg -> [DefSetting] -> J JCfg
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM JCfg -> DefSetting -> J JCfg
go JCfg
env [DefSetting]
cfg
runLF :: (forall e. HasLogFunc e => RIO e a) -> LogFunc -> IO a
runLF :: (forall e. HasLogFunc e => RIO e a) -> LogFunc -> IO a
runLF = (LogFunc -> RIO LogFunc a -> IO a)
-> RIO LogFunc a -> LogFunc -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip LogFunc -> RIO LogFunc a -> IO a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO
getI :: J (LogFunc -> IO (Acquire KeySource))
getI :: J (LogFunc -> IO (Acquire KeySource))
getI = do
[DefSetting]
cfg <- Text -> Prism' KExpr [DefSetting] -> J [DefSetting]
forall a. Text -> Prism' KExpr a -> J a
oneBlock "defcfg" forall r. AsKExpr r => Prism' r [DefSetting]
Prism' KExpr [DefSetting]
_KDefCfg
case [IToken] -> Either SingletonError IToken
forall a. [a] -> Either SingletonError a
onlyOne ([IToken] -> Either SingletonError IToken)
-> ([DefSetting] -> [IToken])
-> [DefSetting]
-> Either SingletonError IToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' DefSetting IToken -> [DefSetting] -> [IToken]
forall a b. Prism' a b -> [a] -> [b]
extract forall r. AsDefSetting r => Prism' r IToken
Prism' DefSetting IToken
_SIToken ([DefSetting] -> Either SingletonError IToken)
-> [DefSetting] -> Either SingletonError IToken
forall a b. (a -> b) -> a -> b
$ [DefSetting]
cfg of
Right i :: IToken
i -> IToken -> J (LogFunc -> IO (Acquire KeySource))
pickInput IToken
i
Left None -> JoinError -> J (LogFunc -> IO (Acquire KeySource))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> J (LogFunc -> IO (Acquire KeySource)))
-> JoinError -> J (LogFunc -> IO (Acquire KeySource))
forall a b. (a -> b) -> a -> b
$ Text -> JoinError
MissingSetting "input"
Left Duplicate -> JoinError -> J (LogFunc -> IO (Acquire KeySource))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> J (LogFunc -> IO (Acquire KeySource)))
-> JoinError -> J (LogFunc -> IO (Acquire KeySource))
forall a b. (a -> b) -> a -> b
$ Text -> JoinError
DuplicateSetting "input"
getO :: J (LogFunc -> IO (Acquire KeySink))
getO :: J (LogFunc -> IO (Acquire KeySink))
getO = do
[DefSetting]
cfg <- Text -> Prism' KExpr [DefSetting] -> J [DefSetting]
forall a. Text -> Prism' KExpr a -> J a
oneBlock "defcfg" forall r. AsKExpr r => Prism' r [DefSetting]
Prism' KExpr [DefSetting]
_KDefCfg
case [OToken] -> Either SingletonError OToken
forall a. [a] -> Either SingletonError a
onlyOne ([OToken] -> Either SingletonError OToken)
-> ([DefSetting] -> [OToken])
-> [DefSetting]
-> Either SingletonError OToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' DefSetting OToken -> [DefSetting] -> [OToken]
forall a b. Prism' a b -> [a] -> [b]
extract forall r. AsDefSetting r => Prism' r OToken
Prism' DefSetting OToken
_SOToken ([DefSetting] -> Either SingletonError OToken)
-> [DefSetting] -> Either SingletonError OToken
forall a b. (a -> b) -> a -> b
$ [DefSetting]
cfg of
Right o :: OToken
o -> OToken -> J (LogFunc -> IO (Acquire KeySink))
pickOutput OToken
o
Left None -> JoinError -> J (LogFunc -> IO (Acquire KeySink))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> J (LogFunc -> IO (Acquire KeySink)))
-> JoinError -> J (LogFunc -> IO (Acquire KeySink))
forall a b. (a -> b) -> a -> b
$ Text -> JoinError
MissingSetting "input"
Left Duplicate -> JoinError -> J (LogFunc -> IO (Acquire KeySink))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> J (LogFunc -> IO (Acquire KeySink)))
-> JoinError -> J (LogFunc -> IO (Acquire KeySink))
forall a b. (a -> b) -> a -> b
$ Text -> JoinError
DuplicateSetting "input"
getFT :: J Bool
getFT :: J Bool
getFT = do
[DefSetting]
cfg <- Text -> Prism' KExpr [DefSetting] -> J [DefSetting]
forall a. Text -> Prism' KExpr a -> J a
oneBlock "defcfg" forall r. AsKExpr r => Prism' r [DefSetting]
Prism' KExpr [DefSetting]
_KDefCfg
case [Bool] -> Either SingletonError Bool
forall a. [a] -> Either SingletonError a
onlyOne ([Bool] -> Either SingletonError Bool)
-> ([DefSetting] -> [Bool])
-> [DefSetting]
-> Either SingletonError Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' DefSetting Bool -> [DefSetting] -> [Bool]
forall a b. Prism' a b -> [a] -> [b]
extract forall r. AsDefSetting r => Prism' r Bool
Prism' DefSetting Bool
_SFallThrough ([DefSetting] -> Either SingletonError Bool)
-> [DefSetting] -> Either SingletonError Bool
forall a b. (a -> b) -> a -> b
$ [DefSetting]
cfg of
Right b :: Bool
b -> Bool -> J Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
b
Left None -> Bool -> J Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
Left Duplicate -> JoinError -> J Bool
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> J Bool) -> JoinError -> J Bool
forall a b. (a -> b) -> a -> b
$ Text -> JoinError
DuplicateSetting "fallthrough"
getAllow :: J Bool
getAllow :: J Bool
getAllow = do
[DefSetting]
cfg <- Text -> Prism' KExpr [DefSetting] -> J [DefSetting]
forall a. Text -> Prism' KExpr a -> J a
oneBlock "defcfg" forall r. AsKExpr r => Prism' r [DefSetting]
Prism' KExpr [DefSetting]
_KDefCfg
case [Bool] -> Either SingletonError Bool
forall a. [a] -> Either SingletonError a
onlyOne ([Bool] -> Either SingletonError Bool)
-> ([DefSetting] -> [Bool])
-> [DefSetting]
-> Either SingletonError Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' DefSetting Bool -> [DefSetting] -> [Bool]
forall a b. Prism' a b -> [a] -> [b]
extract forall r. AsDefSetting r => Prism' r Bool
Prism' DefSetting Bool
_SAllowCmd ([DefSetting] -> Either SingletonError Bool)
-> [DefSetting] -> Either SingletonError Bool
forall a b. (a -> b) -> a -> b
$ [DefSetting]
cfg of
Right b :: Bool
b -> Bool -> J Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
b
Left None -> Bool -> J Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
Left Duplicate -> JoinError -> J Bool
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> J Bool) -> JoinError -> J Bool
forall a b. (a -> b) -> a -> b
$ Text -> JoinError
DuplicateSetting "allow-cmd"
#ifdef linux_HOST_OS
pickInput :: IToken -> J (LogFunc -> IO (Acquire KeySource))
pickInput :: IToken -> J (LogFunc -> IO (Acquire KeySource))
pickInput (KDeviceSource f :: String
f) = (LogFunc -> IO (Acquire KeySource))
-> J (LogFunc -> IO (Acquire KeySource))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((LogFunc -> IO (Acquire KeySource))
-> J (LogFunc -> IO (Acquire KeySource)))
-> (LogFunc -> IO (Acquire KeySource))
-> J (LogFunc -> IO (Acquire KeySource))
forall a b. (a -> b) -> a -> b
$ (forall e. HasLogFunc e => RIO e (Acquire KeySource))
-> LogFunc -> IO (Acquire KeySource)
forall a. (forall e. HasLogFunc e => RIO e a) -> LogFunc -> IO a
runLF (String -> RIO e (Acquire KeySource)
forall e. HasLogFunc e => String -> RIO e (Acquire KeySource)
deviceSource64 String
f)
pickInput KLowLevelHookSource = JoinError -> J (LogFunc -> IO (Acquire KeySource))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> J (LogFunc -> IO (Acquire KeySource)))
-> JoinError -> J (LogFunc -> IO (Acquire KeySource))
forall a b. (a -> b) -> a -> b
$ Text -> JoinError
InvalidOS "LowLevelHookSource"
pickInput (KIOKitSource _) = JoinError -> J (LogFunc -> IO (Acquire KeySource))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> J (LogFunc -> IO (Acquire KeySource)))
-> JoinError -> J (LogFunc -> IO (Acquire KeySource))
forall a b. (a -> b) -> a -> b
$ Text -> JoinError
InvalidOS "IOKitSource"
pickOutput :: OToken -> J (LogFunc -> IO (Acquire KeySink))
pickOutput :: OToken -> J (LogFunc -> IO (Acquire KeySink))
pickOutput (KUinputSink t :: Text
t init :: Maybe Text
init) = (LogFunc -> IO (Acquire KeySink))
-> J (LogFunc -> IO (Acquire KeySink))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((LogFunc -> IO (Acquire KeySink))
-> J (LogFunc -> IO (Acquire KeySink)))
-> (LogFunc -> IO (Acquire KeySink))
-> J (LogFunc -> IO (Acquire KeySink))
forall a b. (a -> b) -> a -> b
$ (forall e. HasLogFunc e => RIO e (Acquire KeySink))
-> LogFunc -> IO (Acquire KeySink)
forall a. (forall e. HasLogFunc e => RIO e a) -> LogFunc -> IO a
runLF (UinputCfg -> RIO e (Acquire KeySink)
forall e. HasLogFunc e => UinputCfg -> RIO e (Acquire KeySink)
uinputSink UinputCfg
cfg)
where cfg :: UinputCfg
cfg = UinputCfg
defUinputCfg { _keyboardName :: String
_keyboardName = Text -> String
T.unpack Text
t
, _postInit :: Maybe String
_postInit = Text -> String
T.unpack (Text -> String) -> Maybe Text -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
init }
pickOutput KSendEventSink = JoinError -> J (LogFunc -> IO (Acquire KeySink))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> J (LogFunc -> IO (Acquire KeySink)))
-> JoinError -> J (LogFunc -> IO (Acquire KeySink))
forall a b. (a -> b) -> a -> b
$ Text -> JoinError
InvalidOS "SendEventSink"
pickOutput KKextSink = JoinError -> J (LogFunc -> IO (Acquire KeySink))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> J (LogFunc -> IO (Acquire KeySink)))
-> JoinError -> J (LogFunc -> IO (Acquire KeySink))
forall a b. (a -> b) -> a -> b
$ Text -> JoinError
InvalidOS "KextSink"
#endif
#ifdef mingw32_HOST_OS
pickInput :: IToken -> J (LogFunc -> IO (Acquire KeySource))
pickInput KLowLevelHookSource = pure $ runLF llHook
pickInput (KDeviceSource _) = throwError $ InvalidOS "DeviceSource"
pickInput (KIOKitSource _) = throwError $ InvalidOS "IOKitSource"
pickOutput :: OToken -> J (LogFunc -> IO (Acquire KeySink))
pickOutput KSendEventSink = pure $ runLF sendEventKeySink
pickOutput (KUinputSink _ _) = throwError $ InvalidOS "UinputSink"
pickOutput KKextSink = throwError $ InvalidOS "KextSink"
#endif
#ifdef darwin_HOST_OS
pickInput :: IToken -> J (LogFunc -> IO (Acquire KeySource))
pickInput (KIOKitSource name) = pure $ runLF (iokitSource (T.unpack <$> name))
pickInput (KDeviceSource _) = throwError $ InvalidOS "DeviceSource"
pickInput KLowLevelHookSource = throwError $ InvalidOS "LowLevelHookSource"
pickOutput :: OToken -> J (LogFunc -> IO (Acquire KeySink))
pickOutput KKextSink = pure $ runLF kextSink
pickOutput (KUinputSink _ _) = throwError $ InvalidOS "UinputSink"
pickOutput KSendEventSink = throwError $ InvalidOS "SendEventSink"
#endif
type Aliases = M.HashMap Text Button
type LNames = [Text]
joinAliases :: LNames -> [DefAlias] -> J Aliases
joinAliases :: LNames -> [DefAlias] -> J Aliases
joinAliases ns :: LNames
ns als :: [DefAlias]
als = (Aliases -> (Text, DefButton) -> J Aliases)
-> Aliases -> DefAlias -> J Aliases
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Aliases -> (Text, DefButton) -> J Aliases
f Aliases
forall k v. HashMap k v
M.empty (DefAlias -> J Aliases) -> DefAlias -> J Aliases
forall a b. (a -> b) -> a -> b
$ [DefAlias] -> DefAlias
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [DefAlias]
als
where f :: Aliases -> (Text, DefButton) -> J Aliases
f mp :: Aliases
mp (t :: Text
t, b :: DefButton
b) = if Text
t Text -> Aliases -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
`M.member` Aliases
mp
then JoinError -> J Aliases
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> J Aliases) -> JoinError -> J Aliases
forall a b. (a -> b) -> a -> b
$ Text -> JoinError
DuplicateAlias Text
t
else (Button -> Aliases -> Aliases) -> Aliases -> Button -> Aliases
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Text -> Button -> Aliases -> Aliases
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert Text
t) Aliases
mp (Button -> Aliases) -> J Button -> J Aliases
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (J (Maybe Button) -> J Button
unnest (J (Maybe Button) -> J Button) -> J (Maybe Button) -> J Button
forall a b. (a -> b) -> a -> b
$ LNames -> Aliases -> DefButton -> J (Maybe Button)
joinButton LNames
ns Aliases
mp DefButton
b)
unnest :: J (Maybe Button) -> J Button
unnest :: J (Maybe Button) -> J Button
unnest = J (J Button) -> J Button
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (J (J Button) -> J Button)
-> (J (Maybe Button) -> J (J Button))
-> J (Maybe Button)
-> J Button
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Button -> J Button) -> J (Maybe Button) -> J (J Button)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (J Button -> (Button -> J Button) -> Maybe Button -> J Button
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (JoinError -> J Button
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError JoinError
NestedTrans) (Button -> J Button
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Button -> J Button) -> (Button -> Button) -> Button -> J Button
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Button -> Button
forall a. a -> a
id))
joinButton :: LNames -> Aliases -> DefButton -> J (Maybe Button)
joinButton :: LNames -> Aliases -> DefButton -> J (Maybe Button)
joinButton ns :: LNames
ns als :: Aliases
als =
let ret :: a -> J (Maybe a)
ret = Maybe a -> J (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> J (Maybe a)) -> (a -> Maybe a) -> a -> J (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just
go :: DefButton -> J Button
go = J (Maybe Button) -> J Button
unnest (J (Maybe Button) -> J Button)
-> (DefButton -> J (Maybe Button)) -> DefButton -> J Button
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LNames -> Aliases -> DefButton -> J (Maybe Button)
joinButton LNames
ns Aliases
als
jst :: J a -> J (Maybe a)
jst = (a -> Maybe a) -> J a -> J (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just
fi :: Int -> Milliseconds
fi = Int -> Milliseconds
forall a b. (Integral a, Num b) => a -> b
fromIntegral
in \case
KRef t :: Text
t -> case Text -> Aliases -> Maybe Button
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup Text
t Aliases
als of
Nothing -> JoinError -> J (Maybe Button)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> J (Maybe Button)) -> JoinError -> J (Maybe Button)
forall a b. (a -> b) -> a -> b
$ Text -> JoinError
MissingAlias Text
t
Just b :: Button
b -> Button -> J (Maybe Button)
forall a. a -> J (Maybe a)
ret Button
b
KEmit c :: Keycode
c -> Button -> J (Maybe Button)
forall a. a -> J (Maybe a)
ret (Button -> J (Maybe Button)) -> Button -> J (Maybe Button)
forall a b. (a -> b) -> a -> b
$ Keycode -> Button
emitB Keycode
c
KCommand t :: Text
t -> Button -> J (Maybe Button)
forall a. a -> J (Maybe a)
ret (Button -> J (Maybe Button)) -> Button -> J (Maybe Button)
forall a b. (a -> b) -> a -> b
$ Text -> Button
cmdButton Text
t
KLayerToggle t :: Text
t -> if Text
t Text -> LNames -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` LNames
ns
then Button -> J (Maybe Button)
forall a. a -> J (Maybe a)
ret (Button -> J (Maybe Button)) -> Button -> J (Maybe Button)
forall a b. (a -> b) -> a -> b
$ Text -> Button
layerToggle Text
t
else JoinError -> J (Maybe Button)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> J (Maybe Button)) -> JoinError -> J (Maybe Button)
forall a b. (a -> b) -> a -> b
$ Text -> JoinError
MissingLayer Text
t
KLayerSwitch t :: Text
t -> if Text
t Text -> LNames -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` LNames
ns
then Button -> J (Maybe Button)
forall a. a -> J (Maybe a)
ret (Button -> J (Maybe Button)) -> Button -> J (Maybe Button)
forall a b. (a -> b) -> a -> b
$ Text -> Button
layerSwitch Text
t
else JoinError -> J (Maybe Button)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> J (Maybe Button)) -> JoinError -> J (Maybe Button)
forall a b. (a -> b) -> a -> b
$ Text -> JoinError
MissingLayer Text
t
KLayerAdd t :: Text
t -> if Text
t Text -> LNames -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` LNames
ns
then Button -> J (Maybe Button)
forall a. a -> J (Maybe a)
ret (Button -> J (Maybe Button)) -> Button -> J (Maybe Button)
forall a b. (a -> b) -> a -> b
$ Text -> Button
layerAdd Text
t
else JoinError -> J (Maybe Button)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> J (Maybe Button)) -> JoinError -> J (Maybe Button)
forall a b. (a -> b) -> a -> b
$ Text -> JoinError
MissingLayer Text
t
KLayerRem t :: Text
t -> if Text
t Text -> LNames -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` LNames
ns
then Button -> J (Maybe Button)
forall a. a -> J (Maybe a)
ret (Button -> J (Maybe Button)) -> Button -> J (Maybe Button)
forall a b. (a -> b) -> a -> b
$ Text -> Button
layerRem Text
t
else JoinError -> J (Maybe Button)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> J (Maybe Button)) -> JoinError -> J (Maybe Button)
forall a b. (a -> b) -> a -> b
$ Text -> JoinError
MissingLayer Text
t
KLayerDelay s :: Int
s t :: Text
t -> if Text
t Text -> LNames -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` LNames
ns
then Button -> J (Maybe Button)
forall a. a -> J (Maybe a)
ret (Button -> J (Maybe Button)) -> Button -> J (Maybe Button)
forall a b. (a -> b) -> a -> b
$ Milliseconds -> Text -> Button
layerDelay (Int -> Milliseconds
fi Int
s) Text
t
else JoinError -> J (Maybe Button)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> J (Maybe Button)) -> JoinError -> J (Maybe Button)
forall a b. (a -> b) -> a -> b
$ Text -> JoinError
MissingLayer Text
t
KLayerNext t :: Text
t -> if Text
t Text -> LNames -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` LNames
ns
then Button -> J (Maybe Button)
forall a. a -> J (Maybe a)
ret (Button -> J (Maybe Button)) -> Button -> J (Maybe Button)
forall a b. (a -> b) -> a -> b
$ Text -> Button
layerNext Text
t
else JoinError -> J (Maybe Button)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> J (Maybe Button)) -> JoinError -> J (Maybe Button)
forall a b. (a -> b) -> a -> b
$ Text -> JoinError
MissingLayer Text
t
KComposeSeq bs :: [DefButton]
bs -> Getting Button JCfg Button -> J Button
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Button JCfg Button
Lens' JCfg Button
cmpKey J Button -> (Button -> J (Maybe Button)) -> J (Maybe Button)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \c :: Button
c -> J Button -> J (Maybe Button)
forall a. J a -> J (Maybe a)
jst (J Button -> J (Maybe Button)) -> J Button -> J (Maybe Button)
forall a b. (a -> b) -> a -> b
$ [Button] -> Button
tapMacro ([Button] -> Button)
-> ([Button] -> [Button]) -> [Button] -> Button
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Button
cButton -> [Button] -> [Button]
forall a. a -> [a] -> [a]
:) ([Button] -> Button) -> J [Button] -> J Button
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DefButton -> J Button) -> [DefButton] -> J [Button]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DefButton -> J Button
go [DefButton]
bs
KTapMacro bs :: [DefButton]
bs -> J Button -> J (Maybe Button)
forall a. J a -> J (Maybe a)
jst (J Button -> J (Maybe Button)) -> J Button -> J (Maybe Button)
forall a b. (a -> b) -> a -> b
$ [Button] -> Button
tapMacro ([Button] -> Button) -> J [Button] -> J Button
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DefButton -> J Button) -> [DefButton] -> J [Button]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DefButton -> J Button
go [DefButton]
bs
KAround o :: DefButton
o i :: DefButton
i -> J Button -> J (Maybe Button)
forall a. J a -> J (Maybe a)
jst (J Button -> J (Maybe Button)) -> J Button -> J (Maybe Button)
forall a b. (a -> b) -> a -> b
$ Button -> Button -> Button
around (Button -> Button -> Button) -> J Button -> J (Button -> Button)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DefButton -> J Button
go DefButton
o J (Button -> Button) -> J Button -> J Button
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DefButton -> J Button
go DefButton
i
KTapNext t :: DefButton
t h :: DefButton
h -> J Button -> J (Maybe Button)
forall a. J a -> J (Maybe a)
jst (J Button -> J (Maybe Button)) -> J Button -> J (Maybe Button)
forall a b. (a -> b) -> a -> b
$ Button -> Button -> Button
tapNext (Button -> Button -> Button) -> J Button -> J (Button -> Button)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DefButton -> J Button
go DefButton
t J (Button -> Button) -> J Button -> J Button
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DefButton -> J Button
go DefButton
h
KTapHold s :: Int
s t :: DefButton
t h :: DefButton
h -> J Button -> J (Maybe Button)
forall a. J a -> J (Maybe a)
jst (J Button -> J (Maybe Button)) -> J Button -> J (Maybe Button)
forall a b. (a -> b) -> a -> b
$ Milliseconds -> Button -> Button -> Button
tapHold (Int -> Milliseconds
fi Int
s) (Button -> Button -> Button) -> J Button -> J (Button -> Button)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DefButton -> J Button
go DefButton
t J (Button -> Button) -> J Button -> J Button
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DefButton -> J Button
go DefButton
h
KTapHoldNext s :: Int
s t :: DefButton
t h :: DefButton
h -> J Button -> J (Maybe Button)
forall a. J a -> J (Maybe a)
jst (J Button -> J (Maybe Button)) -> J Button -> J (Maybe Button)
forall a b. (a -> b) -> a -> b
$ Milliseconds -> Button -> Button -> Button
tapHoldNext (Int -> Milliseconds
fi Int
s) (Button -> Button -> Button) -> J Button -> J (Button -> Button)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DefButton -> J Button
go DefButton
t J (Button -> Button) -> J Button -> J Button
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DefButton -> J Button
go DefButton
h
KTapNextRelease t :: DefButton
t h :: DefButton
h -> J Button -> J (Maybe Button)
forall a. J a -> J (Maybe a)
jst (J Button -> J (Maybe Button)) -> J Button -> J (Maybe Button)
forall a b. (a -> b) -> a -> b
$ Button -> Button -> Button
tapNextRelease (Button -> Button -> Button) -> J Button -> J (Button -> Button)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DefButton -> J Button
go DefButton
t J (Button -> Button) -> J Button -> J Button
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DefButton -> J Button
go DefButton
h
KTapHoldNextRelease ms :: Int
ms t :: DefButton
t h :: DefButton
h
-> J Button -> J (Maybe Button)
forall a. J a -> J (Maybe a)
jst (J Button -> J (Maybe Button)) -> J Button -> J (Maybe Button)
forall a b. (a -> b) -> a -> b
$ Milliseconds -> Button -> Button -> Button
tapHoldNextRelease (Int -> Milliseconds
fi Int
ms) (Button -> Button -> Button) -> J Button -> J (Button -> Button)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DefButton -> J Button
go DefButton
t J (Button -> Button) -> J Button -> J Button
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DefButton -> J Button
go DefButton
h
KAroundNext b :: DefButton
b -> J Button -> J (Maybe Button)
forall a. J a -> J (Maybe a)
jst (J Button -> J (Maybe Button)) -> J Button -> J (Maybe Button)
forall a b. (a -> b) -> a -> b
$ Button -> Button
aroundNext (Button -> Button) -> J Button -> J Button
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DefButton -> J Button
go DefButton
b
KPause ms :: Milliseconds
ms -> J Button -> J (Maybe Button)
forall a. J a -> J (Maybe a)
jst (J Button -> J (Maybe Button))
-> (Button -> J Button) -> Button -> J (Maybe Button)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Button -> J Button
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Button -> J (Maybe Button)) -> Button -> J (Maybe Button)
forall a b. (a -> b) -> a -> b
$ AnyK () -> Button
onPress (Milliseconds -> m ()
forall (m :: * -> *). MonadKIO m => Milliseconds -> m ()
pause Milliseconds
ms)
KMultiTap bs :: [(Int, DefButton)]
bs d :: DefButton
d -> J Button -> J (Maybe Button)
forall a. J a -> J (Maybe a)
jst (J Button -> J (Maybe Button)) -> J Button -> J (Maybe Button)
forall a b. (a -> b) -> a -> b
$ Button -> [(Milliseconds, Button)] -> Button
multiTap (Button -> [(Milliseconds, Button)] -> Button)
-> J Button -> J ([(Milliseconds, Button)] -> Button)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DefButton -> J Button
go DefButton
d J ([(Milliseconds, Button)] -> Button)
-> J [(Milliseconds, Button)] -> J Button
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Int, DefButton) -> J (Milliseconds, Button))
-> [(Int, DefButton)] -> J [(Milliseconds, Button)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int, DefButton) -> J (Milliseconds, Button)
f [(Int, DefButton)]
bs
where f :: (Int, DefButton) -> J (Milliseconds, Button)
f (ms :: Int
ms, b :: DefButton
b) = (Int -> Milliseconds
fi Int
ms,) (Button -> (Milliseconds, Button))
-> J Button -> J (Milliseconds, Button)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DefButton -> J Button
go DefButton
b
KTrans -> Maybe Button -> J (Maybe Button)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Button
forall a. Maybe a
Nothing
KBlock -> Button -> J (Maybe Button)
forall a. a -> J (Maybe a)
ret Button
pass
joinKeymap :: DefSrc -> [DefAlias] -> [DefLayer] -> J (LMap Button, LayerTag)
joinKeymap :: DefSrc -> [DefAlias] -> [DefLayer] -> J (LMap Button, Text)
joinKeymap _ _ [] = JoinError -> J (LMap Button, Text)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> J (LMap Button, Text))
-> JoinError -> J (LMap Button, Text)
forall a b. (a -> b) -> a -> b
$ Text -> JoinError
MissingBlock "deflayer"
joinKeymap src :: DefSrc
src als :: [DefAlias]
als lys :: [DefLayer]
lys = do
let f :: LNames -> Text -> m LNames
f acc :: LNames
acc x :: Text
x = if Text
x Text -> LNames -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` LNames
acc then JoinError -> m LNames
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> m LNames) -> JoinError -> m LNames
forall a b. (a -> b) -> a -> b
$ Text -> JoinError
DuplicateLayer Text
x else LNames -> m LNames
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
xText -> LNames -> LNames
forall a. a -> [a] -> [a]
:LNames
acc)
LNames
nms <- (LNames -> Text -> J LNames) -> LNames -> LNames -> J LNames
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM LNames -> Text -> J LNames
forall (m :: * -> *).
MonadError JoinError m =>
LNames -> Text -> m LNames
f [] (LNames -> J LNames) -> LNames -> J LNames
forall a b. (a -> b) -> a -> b
$ (DefLayer -> Text) -> [DefLayer] -> LNames
forall a b. (a -> b) -> [a] -> [b]
map DefLayer -> Text
_layerName [DefLayer]
lys
Aliases
als' <- LNames -> [DefAlias] -> J Aliases
joinAliases LNames
nms [DefAlias]
als
[(Text, [(Keycode, Button)])]
lys' <- (DefLayer -> J (Text, [(Keycode, Button)]))
-> [DefLayer] -> J [(Text, [(Keycode, Button)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Aliases
-> LNames -> DefSrc -> DefLayer -> J (Text, [(Keycode, Button)])
joinLayer Aliases
als' LNames
nms DefSrc
src) [DefLayer]
lys
(LMap Button, Text) -> J (LMap Button, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((LMap Button, Text) -> J (LMap Button, Text))
-> (LMap Button, Text) -> J (LMap Button, Text)
forall a b. (a -> b) -> a -> b
$ ([(Text, [(Keycode, Button)])] -> LMap Button
forall (t1 :: * -> *) (t2 :: * -> *) k l a.
(Foldable t1, Foldable t2, CanKey k, CanKey l) =>
t1 (l, t2 (k, a)) -> LayerStack l k a
L.mkLayerStack [(Text, [(Keycode, Button)])]
lys', DefLayer -> Text
_layerName (DefLayer -> Text)
-> ([DefLayer] -> DefLayer) -> [DefLayer] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe DefLayer -> DefLayer
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe DefLayer -> DefLayer)
-> ([DefLayer] -> Maybe DefLayer) -> [DefLayer] -> DefLayer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DefLayer] -> Maybe DefLayer
forall a. [a] -> Maybe a
headMaybe ([DefLayer] -> Text) -> [DefLayer] -> Text
forall a b. (a -> b) -> a -> b
$ [DefLayer]
lys)
joinLayer ::
Aliases
-> LNames
-> DefSrc
-> DefLayer
-> J (Text, [(Keycode, Button)])
joinLayer :: Aliases
-> LNames -> DefSrc -> DefLayer -> J (Text, [(Keycode, Button)])
joinLayer als :: Aliases
als ns :: LNames
ns src :: DefSrc
src DefLayer{_layerName :: DefLayer -> Text
_layerName=Text
n, _buttons :: DefLayer -> [DefButton]
_buttons=[DefButton]
bs} = do
Bool -> J () -> J ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([DefButton] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DefButton]
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= DefSrc -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length DefSrc
src) (J () -> J ()) -> J () -> J ()
forall a b. (a -> b) -> a -> b
$
JoinError -> J ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> J ()) -> JoinError -> J ()
forall a b. (a -> b) -> a -> b
$ Text -> Int -> Int -> JoinError
LengthMismatch Text
n ([DefButton] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DefButton]
bs) (DefSrc -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length DefSrc
src)
let f :: [(Keycode, Button)]
-> (Keycode, DefButton) -> J [(Keycode, Button)]
f acc :: [(Keycode, Button)]
acc (kc :: Keycode
kc, b :: DefButton
b) = LNames -> Aliases -> DefButton -> J (Maybe Button)
joinButton LNames
ns Aliases
als DefButton
b J (Maybe Button)
-> (Maybe Button -> J [(Keycode, Button)]) -> J [(Keycode, Button)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Nothing -> [(Keycode, Button)] -> J [(Keycode, Button)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Keycode, Button)]
acc
Just b' :: Button
b' -> [(Keycode, Button)] -> J [(Keycode, Button)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Keycode, Button)] -> J [(Keycode, Button)])
-> [(Keycode, Button)] -> J [(Keycode, Button)]
forall a b. (a -> b) -> a -> b
$ (Keycode
kc, Button
b') (Keycode, Button) -> [(Keycode, Button)] -> [(Keycode, Button)]
forall a. a -> [a] -> [a]
: [(Keycode, Button)]
acc
(Text
n,) ([(Keycode, Button)] -> (Text, [(Keycode, Button)]))
-> J [(Keycode, Button)] -> J (Text, [(Keycode, Button)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([(Keycode, Button)]
-> (Keycode, DefButton) -> J [(Keycode, Button)])
-> [(Keycode, Button)]
-> [(Keycode, DefButton)]
-> J [(Keycode, Button)]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [(Keycode, Button)]
-> (Keycode, DefButton) -> J [(Keycode, Button)]
f [] (DefSrc -> [DefButton] -> [(Keycode, DefButton)]
forall a b. [a] -> [b] -> [(a, b)]
zip DefSrc
src [DefButton]
bs)