{-# LANGUAGE CPP #-}
{-|
Module      : KMonad.Args.Joiner
Description : The code that turns tokens into a DaemonCfg
Copyright   : (c) David Janssen, 2019
License     : MIT

Maintainer  : janssen.dhj@gmail.com
Stability   : experimental
Portability : non-portable (MPTC with FD, FFI to Linux-only c-code)

We perform configuration parsing in 2 steps:
- 1. We turn the text-file into a token representation
- 2. We check the tokens and turn them into an AppCfg

This module covers step 2.

NOTE: This is where we make a distinction between operating systems.

-}
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

--------------------------------------------------------------------------------
-- $err

-- | All the things that can go wrong with a joining attempt
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

-- | Joining Config
data JCfg = JCfg
  { JCfg -> Button
_cmpKey  :: Button  -- ^ How to prefix compose-sequences
  , JCfg -> [KExpr]
_kes     :: [KExpr] -- ^ The source expresions we operate on
  }
makeLenses ''JCfg

defJCfg :: [KExpr] ->JCfg
defJCfg :: [KExpr] -> JCfg
defJCfg = Button -> [KExpr] -> JCfg
JCfg
  (Keycode -> Button
emitB Keycode
KeyRightAlt)

-- | Monad in which we join, just Except over Reader
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)

-- | Perform a joining computation
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)

--------------------------------------------------------------------------------
-- $full

-- | Turn a list of KExpr into a CfgToken, throwing errors when encountered.
--
-- NOTE: We start joinConfig with the default JCfg, but joinConfig might locally
-- override settings by things it reads from the config itself.
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 anything matching a particular prism from a list
extract :: Prism' a b -> [a] -> [b]
extract :: Prism' a b -> [a] -> [b]
extract 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

-- | Take the head of a list, or else throw the appropriate error
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

-- | Take the one and only block matching the prism from the expressions
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

-- | Update the JCfg and then run the entire joining process
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')

-- | Join an entire 'CfgToken' from the current list of 'KExpr'.
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

  -- Extract the IO settings
  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

  -- Extract the other blocks and join them into a keymap
  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
    }

--------------------------------------------------------------------------------
-- $settings
--
-- TODO: This needs to be seriously refactored: all this code duplication is a
-- sign that something is amiss.

-- | Return a JCfg with all settings from defcfg applied to the env's JCfg
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

-- | Turn a 'HasLogFunc'-only RIO into a function from LogFunc to IO
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


-- | Extract the KeySource-loader from the 'KExpr's
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"

-- | Extract the KeySource-loader from a 'KExpr's
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"

-- | Extract the fallthrough setting
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"

-- | Extract the fallthrough setting
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

-- | The Linux correspondence between IToken and actual code
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"

-- | The Linux correspondence between OToken and actual code
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

-- | The Windows correspondence between IToken and actual code
pickInput :: IToken -> J (LogFunc -> IO (Acquire KeySource))
pickInput KLowLevelHookSource = pure $ runLF llHook
pickInput (KDeviceSource _)   = throwError $ InvalidOS "DeviceSource"
pickInput (KIOKitSource _)    = throwError $ InvalidOS "IOKitSource"

-- | The Windows correspondence between OToken and actual code
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

-- | The Mac correspondence between IToken and actual code
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"

-- | The Mac correspondence between OToken and actual code
pickOutput :: OToken -> J (LogFunc -> IO (Acquire KeySink))
pickOutput KKextSink            = pure $ runLF kextSink
pickOutput (KUinputSink _ _)    = throwError $ InvalidOS "UinputSink"
pickOutput KSendEventSink       = throwError $ InvalidOS "SendEventSink"

#endif

--------------------------------------------------------------------------------
-- $als

type Aliases = M.HashMap Text Button
type LNames  = [Text]

-- | Build up a hashmap of text to button mappings
--
-- Aliases can refer back to buttons that occured before.
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)

--------------------------------------------------------------------------------
-- $but

-- | Turn 'Nothing's (caused by joining a KTrans) into the appropriate error.
-- KTrans buttons may only occur in 'DefLayer' definitions.
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))

-- | Turn a button token into an actual KMonad `Button` value
joinButton :: LNames -> Aliases -> DefButton -> J (Maybe Button)
joinButton :: LNames -> Aliases -> DefButton -> J (Maybe Button)
joinButton ns :: LNames
ns als :: Aliases
als =

  -- Define some utility functions
  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
    -- Variable dereference
    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

    -- Various simple buttons
    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

    -- Various compound buttons
    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

    -- Non-action buttons
    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


--------------------------------------------------------------------------------
-- $kmap

-- | Join the defsrc, defalias, and deflayer layers into a Keymap of buttons and
-- the name signifying the initial layer to load.
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   -- Extract all names
  Aliases
als' <- LNames -> [DefAlias] -> J Aliases
joinAliases LNames
nms [DefAlias]
als               -- Join aliases into 1 hashmap
  [(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 -- Join all layers
  -- Return the layerstack and the name of the first layer
  (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)

-- | Check and join 1 deflayer.
joinLayer ::
     Aliases                       -- ^ Mapping of names to buttons
  -> LNames                        -- ^ List of valid layer names
  -> DefSrc                        -- ^ Layout of the source layer
  -> DefLayer                      -- ^ The layer token to join
  -> J (Text, [(Keycode, Button)]) -- ^ The resulting tuple
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

  -- Ensure length-match between src and buttons
  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)

  -- Join each button and add it (filtering out KTrans)
  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)


--------------------------------------------------------------------------------
-- $test

-- fname :: String
-- fname = "/home/david/prj/hask/kmonad/doc/example.kbd"

-- test :: IO (J DefCfg)
-- test = runRIO () . fmap joinConfig $ loadTokens fname