{-# LANGUAGE CPP #-}
module KMonad.Args.Joiner
( joinConfigIO
, joinConfig
)
where
import KMonad.Prelude hiding (uncons)
import KMonad.Args.Types
import KMonad.Model.Action
import KMonad.Model.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 (headMaybe, intersperse, uncons)
import RIO.Partial (fromJust)
import qualified KMonad.Util.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 JoinError
e = case JoinError
e of
DuplicateBlock Text
t -> String
"Encountered duplicate block of type: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t
MissingBlock Text
t -> String
"Missing at least 1 block of type: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t
DuplicateAlias Text
t -> String
"Multiple aliases of the same name: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t
DuplicateLayer Text
t -> String
"Multiple layers of the same name: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t
MissingAlias Text
t -> String
"Reference to non-existent alias: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t
MissingLayer Text
t -> String
"Reference to non-existent layer: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t
MissingSetting Text
t -> String
"Missing setting in 'defcfg': " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t
DuplicateSetting Text
t -> String
"Duplicate setting in 'defcfg': " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t
InvalidOS Text
t -> String
"Not available under this OS: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t
JoinError
NestedTrans -> String
"Encountered 'Transparent' ouside of top-level layer"
JoinError
InvalidComposeKey -> String
"Encountered invalid button as Compose key"
LengthMismatch Text
t Int
l Int
s -> [String] -> String
forall a. Monoid a => [a] -> a
mconcat
[ String
"Mismatch between length of 'defsrc' and deflayer <", Text -> String
T.unpack Text
t, String
">\n"
, String
"Source length: ", Int -> String
forall a. Show a => a -> String
show Int
s, String
"\n"
, String
"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 { forall a. J a -> ExceptT JoinError (Reader JCfg) a
unJ :: ExceptT JoinError (Reader JCfg) a }
deriving ( (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
$cfmap :: forall a b. (a -> b) -> J a -> J b
fmap :: forall a b. (a -> b) -> J a -> J b
$c<$ :: forall a b. a -> J b -> J a
<$ :: forall a b. a -> J b -> J a
Functor, Functor J
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
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
$cpure :: forall a. a -> J a
pure :: forall a. a -> J a
$c<*> :: forall a b. J (a -> b) -> J a -> J b
<*> :: forall a b. J (a -> b) -> J a -> J b
$cliftA2 :: forall a b c. (a -> b -> c) -> J a -> J b -> J c
liftA2 :: forall a b c. (a -> b -> c) -> J a -> J b -> J c
$c*> :: forall a b. J a -> J b -> J b
*> :: forall a b. J a -> J b -> J b
$c<* :: forall a b. J a -> J b -> J a
<* :: forall a b. J a -> J b -> J a
Applicative, Applicative J
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
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
$c>>= :: forall a b. J a -> (a -> J b) -> J b
>>= :: forall a b. J a -> (a -> J b) -> J b
$c>> :: forall a b. J a -> J b -> J b
>> :: forall a b. J a -> J b -> J b
$creturn :: forall a. a -> J a
return :: forall a. a -> J a
Monad
, MonadError JoinError , MonadReader JCfg)
runJ :: J a -> JCfg -> Either JoinError a
runJ :: forall a. J a -> JCfg -> Either JoinError a
runJ 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 :: forall e. HasLogFunc e => [KExpr] -> RIO e CfgToken
joinConfigIO [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 JoinError
e -> JoinError -> RIO e CfgToken
forall e a. Exception e => e -> RIO e a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM JoinError
e
Right CfgToken
c -> CfgToken -> RIO e CfgToken
forall a. a -> RIO e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CfgToken
c
extract :: Prism' a b -> [a] -> [b]
Prism' a b
p = (a -> Maybe b) -> [a] -> [b]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (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 :: forall a. [a] -> Either SingletonError a
onlyOne [a]
xs = case [a] -> Maybe (a, [a])
forall a. [a] -> Maybe (a, [a])
uncons [a]
xs of
Just (a
x, []) -> a -> Either SingletonError a
forall a b. b -> Either a b
Right a
x
Just (a, [a])
_ -> SingletonError -> Either SingletonError a
forall a b. a -> Either a b
Left SingletonError
Duplicate
Maybe (a, [a])
Nothing -> SingletonError -> Either SingletonError a
forall a b. a -> Either a b
Left SingletonError
None
oneBlock :: Text -> Prism' KExpr a -> J a
oneBlock :: forall a. Text -> Prism' KExpr a -> J a
oneBlock Text
t Prism' KExpr a
l = (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 [KExpr]
-> ([KExpr] -> Either SingletonError a)
-> J (Either SingletonError a)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Prism' KExpr a -> [KExpr] -> [a]
forall a b. Prism' a b -> [a] -> [b]
extract p a (f a) -> p KExpr (f KExpr)
Prism' KExpr a
l ([KExpr] -> [a])
-> ([a] -> Either SingletonError a)
-> [KExpr]
-> Either SingletonError a
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> [a] -> Either SingletonError a
forall a. [a] -> Either SingletonError a
onlyOne)) J (Either SingletonError a)
-> (Either SingletonError a -> J a) -> J a
forall a b. J a -> (a -> J b) -> J b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Right a
x -> a -> J a
forall a. a -> J a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
Left SingletonError
None -> JoinError -> J a
forall a. 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 SingletonError
Duplicate -> JoinError -> J a
forall a. 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 a b. J a -> (a -> J b) -> J b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \JCfg
cfg -> (JCfg -> JCfg) -> J CfgToken -> J CfgToken
forall a. (JCfg -> JCfg) -> J a -> J a
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 p DefAlias (f DefAlias) -> p KExpr (f KExpr)
forall r. AsKExpr r => Prism' r DefAlias
Prism' KExpr DefAlias
_KDefAlias [KExpr]
es
let lys :: [DefLayer]
lys = Prism' KExpr DefLayer -> [KExpr] -> [DefLayer]
forall a b. Prism' a b -> [a] -> [b]
extract p DefLayer (f DefLayer) -> p KExpr (f KExpr)
forall r. AsKExpr r => Prism' r DefLayer
Prism' KExpr DefLayer
_KDefLayer [KExpr]
es
DefSrc
src <- Text -> Prism' KExpr DefSrc -> J DefSrc
forall a. Text -> Prism' KExpr a -> J a
oneBlock Text
"defsrc" p DefSrc (f DefSrc) -> p KExpr (f KExpr)
forall r. AsKExpr r => Prism' r DefSrc
Prism' KExpr DefSrc
_KDefSrc
(LMap Button
km, Text
fl) <- DefSrc -> [DefAlias] -> [DefLayer] -> J (LMap Button, Text)
joinKeymap DefSrc
src [DefAlias]
als [DefLayer]
lys
CfgToken -> J CfgToken
forall a. a -> J a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CfgToken -> J CfgToken) -> CfgToken -> J CfgToken
forall a b. (a -> b) -> a -> b
$ 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 Text
"defcfg" p [DefSetting] (f [DefSetting]) -> p KExpr (f KExpr)
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 JCfg
e DefSetting
v = case DefSetting
v of
SCmpSeq DefButton
b -> DefButton -> J (Maybe Button)
getB DefButton
b J (Maybe Button) -> (Maybe Button -> J JCfg) -> J JCfg
forall a b. J a -> (a -> J b) -> J b
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 a. JoinError -> J a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError JoinError
InvalidComposeKey)
(\Button
b' -> JCfg -> J JCfg
forall a. a -> J a
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)
DefSetting
_ -> JCfg -> J JCfg
forall a. a -> J a
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 :: HasLogFunc lf => RIO lf a -> lf -> IO a
runLF :: forall lf a. HasLogFunc lf => RIO lf a -> lf -> IO a
runLF = (lf -> RIO lf a -> IO a) -> RIO lf a -> lf -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip lf -> RIO lf 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 Text
"defcfg" p [DefSetting] (f [DefSetting]) -> p KExpr (f KExpr)
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 p IToken (f IToken) -> p DefSetting (f DefSetting)
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 IToken
i -> IToken -> J (LogFunc -> IO (Acquire KeySource))
pickInput IToken
i
Left SingletonError
None -> JoinError -> J (LogFunc -> IO (Acquire KeySource))
forall a. JoinError -> J a
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 Text
"input"
Left SingletonError
Duplicate -> JoinError -> J (LogFunc -> IO (Acquire KeySource))
forall a. JoinError -> J a
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 Text
"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 Text
"defcfg" p [DefSetting] (f [DefSetting]) -> p KExpr (f KExpr)
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 p OToken (f OToken) -> p DefSetting (f DefSetting)
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 OToken
o -> OToken -> J (LogFunc -> IO (Acquire KeySink))
pickOutput OToken
o
Left SingletonError
None -> JoinError -> J (LogFunc -> IO (Acquire KeySink))
forall a. JoinError -> J a
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 Text
"input"
Left SingletonError
Duplicate -> JoinError -> J (LogFunc -> IO (Acquire KeySink))
forall a. JoinError -> J a
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 Text
"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 Text
"defcfg" p [DefSetting] (f [DefSetting]) -> p KExpr (f KExpr)
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 p Bool (f Bool) -> p DefSetting (f DefSetting)
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 Bool
b -> Bool -> J Bool
forall a. a -> J a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
b
Left SingletonError
None -> Bool -> J Bool
forall a. a -> J a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
Left SingletonError
Duplicate -> JoinError -> J Bool
forall a. JoinError -> J a
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 Text
"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 Text
"defcfg" p [DefSetting] (f [DefSetting]) -> p KExpr (f KExpr)
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 p Bool (f Bool) -> p DefSetting (f DefSetting)
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 Bool
b -> Bool -> J Bool
forall a. a -> J a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
b
Left SingletonError
None -> Bool -> J Bool
forall a. a -> J a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
Left SingletonError
Duplicate -> JoinError -> J Bool
forall a. JoinError -> J a
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 Text
"allow-cmd"
getCmpSeqDelay :: J (Maybe Int)
getCmpSeqDelay :: J (Maybe Int)
getCmpSeqDelay = do
[DefSetting]
cfg <- Text -> Prism' KExpr [DefSetting] -> J [DefSetting]
forall a. Text -> Prism' KExpr a -> J a
oneBlock Text
"defcfg" p [DefSetting] (f [DefSetting]) -> p KExpr (f KExpr)
forall r. AsKExpr r => Prism' r [DefSetting]
Prism' KExpr [DefSetting]
_KDefCfg
case [Int] -> Either SingletonError Int
forall a. [a] -> Either SingletonError a
onlyOne ([Int] -> Either SingletonError Int)
-> ([DefSetting] -> [Int])
-> [DefSetting]
-> Either SingletonError Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' DefSetting Int -> [DefSetting] -> [Int]
forall a b. Prism' a b -> [a] -> [b]
extract p Int (f Int) -> p DefSetting (f DefSetting)
forall r. AsDefSetting r => Prism' r Int
Prism' DefSetting Int
_SCmpSeqDelay ([DefSetting] -> Either SingletonError Int)
-> [DefSetting] -> Either SingletonError Int
forall a b. (a -> b) -> a -> b
$ [DefSetting]
cfg of
Right Int
b -> Maybe Int -> J (Maybe Int)
forall a. a -> J a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
b)
Left SingletonError
None -> Maybe Int -> J (Maybe Int)
forall a. a -> J a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing
Left SingletonError
Duplicate -> JoinError -> J (Maybe Int)
forall a. JoinError -> J a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> J (Maybe Int)) -> JoinError -> J (Maybe Int)
forall a b. (a -> b) -> a -> b
$ Text -> JoinError
DuplicateSetting Text
"cmp-seq-delay"
#ifdef linux_HOST_OS
pickInput :: IToken -> J (LogFunc -> IO (Acquire KeySource))
pickInput :: IToken -> J (LogFunc -> IO (Acquire KeySource))
pickInput (KDeviceSource String
f) = (LogFunc -> IO (Acquire KeySource))
-> J (LogFunc -> IO (Acquire KeySource))
forall a. a -> J a
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
$ RIO LogFunc (Acquire KeySource)
-> LogFunc -> IO (Acquire KeySource)
forall lf a. HasLogFunc lf => RIO lf a -> lf -> IO a
runLF (String -> RIO LogFunc (Acquire KeySource)
forall e. HasLogFunc e => String -> RIO e (Acquire KeySource)
deviceSource64 String
f)
pickInput IToken
KLowLevelHookSource = JoinError -> J (LogFunc -> IO (Acquire KeySource))
forall a. JoinError -> J a
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 Text
"LowLevelHookSource"
pickInput (KIOKitSource Maybe Text
_) = JoinError -> J (LogFunc -> IO (Acquire KeySource))
forall a. JoinError -> J a
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 Text
"IOKitSource"
pickOutput :: OToken -> J (LogFunc -> IO (Acquire KeySink))
pickOutput :: OToken -> J (LogFunc -> IO (Acquire KeySink))
pickOutput (KUinputSink Text
t Maybe Text
init) = (LogFunc -> IO (Acquire KeySink))
-> J (LogFunc -> IO (Acquire KeySink))
forall a. a -> J a
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
$ RIO LogFunc (Acquire KeySink) -> LogFunc -> IO (Acquire KeySink)
forall lf a. HasLogFunc lf => RIO lf a -> lf -> IO a
runLF (UinputCfg -> RIO LogFunc (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 Maybe (Int, Int)
_) = JoinError -> J (LogFunc -> IO (Acquire KeySink))
forall a. JoinError -> J a
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 Text
"SendEventSink"
pickOutput OToken
KKextSink = JoinError -> J (LogFunc -> IO (Acquire KeySink))
forall a. JoinError -> J a
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 Text
"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 di) = pure $ runLF (sendEventKeySink di)
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 LNames
ns [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 Aliases
mp (Text
t, 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 a. JoinError -> J a
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 (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 Button -> (Button -> J Button) -> Maybe Button -> J Button
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (JoinError -> J Button
forall a. JoinError -> J a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError JoinError
NestedTrans) Button -> J Button
forall a. a -> J a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Button -> J Button) -> J (Maybe Button) -> J Button
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<)
joinButton :: LNames -> Aliases -> DefButton -> J (Maybe Button)
joinButton :: LNames -> Aliases -> DefButton -> J (Maybe Button)
joinButton LNames
ns Aliases
als =
let ret :: a -> J (Maybe a)
ret = Maybe a -> J (Maybe a)
forall a. a -> J 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 a b. (a -> b) -> J a -> J b
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
isps :: [DefButton] -> Maybe Int -> J [Button]
isps [DefButton]
l = (DefButton -> J Button) -> [DefButton] -> J [Button]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse DefButton -> J Button
go ([DefButton] -> J [Button])
-> (Maybe Int -> [DefButton]) -> Maybe Int -> J [Button]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DefButton] -> (Int -> [DefButton]) -> Maybe Int -> [DefButton]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [DefButton]
l ((DefButton -> [DefButton] -> [DefButton]
forall a. a -> [a] -> [a]
`intersperse` [DefButton]
l) (DefButton -> [DefButton])
-> (Int -> DefButton) -> Int -> [DefButton]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Milliseconds -> DefButton
KPause (Milliseconds -> DefButton)
-> (Int -> Milliseconds) -> Int -> DefButton
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Milliseconds
fi)
in \case
KRef 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
Maybe Button
Nothing -> JoinError -> J (Maybe Button)
forall a. JoinError -> J a
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 Button
b -> Button -> J (Maybe Button)
forall {a}. a -> J (Maybe a)
ret Button
b
KEmit 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
KPressOnly 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
pressOnly Keycode
c
KReleaseOnly 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
releaseOnly Keycode
c
KCommand Text
pr Maybe Text
mbR -> 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 -> Maybe Text -> Button
cmdButton Text
pr Maybe Text
mbR
KLayerToggle Text
t -> if Text
t Text -> LNames -> Bool
forall a. Eq a => a -> [a] -> 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 a. JoinError -> J a
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 Text
t -> if Text
t Text -> LNames -> Bool
forall a. Eq a => a -> [a] -> 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 a. JoinError -> J a
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 Text
t -> if Text
t Text -> LNames -> Bool
forall a. Eq a => a -> [a] -> 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 a. JoinError -> J a
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 Text
t -> if Text
t Text -> LNames -> Bool
forall a. Eq a => a -> [a] -> 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 a. JoinError -> J a
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 Int
s Text
t -> if Text
t Text -> LNames -> Bool
forall a. Eq a => a -> [a] -> 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 a. JoinError -> J a
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 Text
t -> if Text
t Text -> LNames -> Bool
forall a. Eq a => a -> [a] -> 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 a. JoinError -> J a
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 [DefButton]
bs -> do Maybe Int
csd <- J (Maybe Int)
getCmpSeqDelay
Button
c <- 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 -> 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] -> Maybe Int -> J [Button]
isps [DefButton]
bs Maybe Int
csd
KTapMacro [DefButton]
bs Maybe Int
mbD -> 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] -> Maybe Int -> J [Button]
isps [DefButton]
bs Maybe Int
mbD
KBeforeAfterNext DefButton
b DefButton
a -> 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
beforeAfterNext (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
b J (Button -> Button) -> J Button -> J Button
forall a b. J (a -> b) -> J a -> J b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DefButton -> J Button
go DefButton
a
KTapMacroRelease [DefButton]
bs Maybe Int
mbD ->
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
tapMacroRelease ([Button] -> Button) -> J [Button] -> J Button
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DefButton] -> Maybe Int -> J [Button]
isps [DefButton]
bs Maybe Int
mbD
KAround DefButton
o 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 a b. J (a -> b) -> J a -> J b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DefButton -> J Button
go DefButton
i
KTapNext DefButton
t 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 a b. J (a -> b) -> J a -> J b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DefButton -> J Button
go DefButton
h
KTapHold Int
s DefButton
t 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 a b. J (a -> b) -> J a -> J b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DefButton -> J Button
go DefButton
h
KTapHoldNext Int
s DefButton
t DefButton
h Maybe DefButton
mtb
-> 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 -> Maybe Button -> Button
tapHoldNext (Int -> Milliseconds
fi Int
s) (Button -> Button -> Maybe Button -> Button)
-> J Button -> J (Button -> Maybe Button -> Button)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DefButton -> J Button
go DefButton
t J (Button -> Maybe Button -> Button)
-> J Button -> J (Maybe Button -> Button)
forall a b. J (a -> b) -> J a -> J b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DefButton -> J Button
go DefButton
h J (Maybe Button -> Button) -> J (Maybe Button) -> J Button
forall a b. J (a -> b) -> J a -> J b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (DefButton -> J Button) -> Maybe DefButton -> J (Maybe Button)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse DefButton -> J Button
go Maybe DefButton
mtb
KTapNextRelease DefButton
t 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 a b. J (a -> b) -> J a -> J b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DefButton -> J Button
go DefButton
h
KTapHoldNextRelease Int
ms DefButton
t DefButton
h Maybe DefButton
mtb
-> 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 -> Maybe Button -> Button
tapHoldNextRelease (Int -> Milliseconds
fi Int
ms) (Button -> Button -> Maybe Button -> Button)
-> J Button -> J (Button -> Maybe Button -> Button)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DefButton -> J Button
go DefButton
t J (Button -> Maybe Button -> Button)
-> J Button -> J (Maybe Button -> Button)
forall a b. J (a -> b) -> J a -> J b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DefButton -> J Button
go DefButton
h J (Maybe Button -> Button) -> J (Maybe Button) -> J Button
forall a b. J (a -> b) -> J a -> J b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (DefButton -> J Button) -> Maybe DefButton -> J (Maybe Button)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse DefButton -> J Button
go Maybe DefButton
mtb
KTapNextPress DefButton
t 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
tapNextPress (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 a b. J (a -> b) -> J a -> J b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DefButton -> J Button
go DefButton
h
KAroundNext 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
KAroundNextSingle 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
aroundNextSingle (Button -> Button) -> J Button -> J Button
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DefButton -> J Button
go DefButton
b
KAroundNextTimeout Int
ms DefButton
b DefButton
t -> 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
aroundNextTimeout (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
b J (Button -> Button) -> J Button -> J Button
forall a b. J (a -> b) -> J a -> J b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DefButton -> J Button
go DefButton
t
KPause 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 a. a -> J a
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 [(Int, DefButton)]
bs 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 a b. J (a -> b) -> J a -> J b
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Int, DefButton) -> J (Milliseconds, Button)
f [(Int, DefButton)]
bs
where f :: (Int, DefButton) -> J (Milliseconds, Button)
f (Int
ms, 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
KStickyKey Int
s 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
$ Milliseconds -> Button -> Button
stickyKey (Int -> Milliseconds
fi Int
s) (Button -> Button) -> J Button -> J Button
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DefButton -> J Button
go DefButton
d
DefButton
KTrans -> Maybe Button -> J (Maybe Button)
forall a. a -> J a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Button
forall a. Maybe a
Nothing
DefButton
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 DefSrc
_ [DefAlias]
_ [] = JoinError -> J (LMap Button, Text)
forall a. JoinError -> J a
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 Text
"deflayer"
joinKeymap DefSrc
src [DefAlias]
als [DefLayer]
lys = do
let f :: LNames -> Text -> m LNames
f LNames
acc Text
x = if Text
x Text -> LNames -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` LNames
acc then JoinError -> m LNames
forall a. JoinError -> m a
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 a. a -> m a
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a. a -> J a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(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 Aliases
als LNames
ns 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 a. [a] -> 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 a. [a] -> 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 a. JoinError -> J a
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 a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DefButton]
bs) (DefSrc -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length DefSrc
src)
let f :: [(Keycode, Button)]
-> (Keycode, DefButton) -> J [(Keycode, Button)]
f [(Keycode, Button)]
acc (Keycode
kc, 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 a b. J a -> (a -> J b) -> J b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Button
Nothing -> [(Keycode, Button)] -> J [(Keycode, Button)]
forall a. a -> J a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Keycode, Button)]
acc
Just Button
b' -> [(Keycode, Button)] -> J [(Keycode, Button)]
forall a. a -> J a
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)