{-# 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.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, sort, group)
import RIO.Partial (fromJust)
import qualified KMonad.Util.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
  | DuplicateSource  (Maybe Text)
  | DuplicateKeyInSource (Maybe Text) [Keycode]
  | MissingAlias     Text
  | MissingLayer     Text
  | MissingSource    (Maybe Text)
  | MissingSetting   Text
  | DuplicateSetting Text
  | DuplicateLayerSetting Text Text
  | InvalidOS        Text
  | ImplArndDisabled
  | 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
    DuplicateSource   Maybe Text
t   -> case Maybe Text
t of
      Just Text
t  -> String
"Multiple sources of the same name: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t
      Maybe Text
Nothing -> String
"Multiple default sources"
    DuplicateKeyInSource   Maybe Text
t [Keycode]
ks   -> case Maybe Text
t of
      Just Text
t  -> String
"Keycodes appear multiple times in source `" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"`:" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ((Char
' ' Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> (Keycode -> String) -> Keycode -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Keycode -> String
forall a. Show a => a -> String
show (Keycode -> String) -> [Keycode] -> String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Keycode]
ks)
      Maybe Text
Nothing -> String
"Keycodes appear multiple times in default source: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ((Char
' ' Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> (Keycode -> String) -> Keycode -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Keycode -> String
forall a. Show a => a -> String
show (Keycode -> String) -> [Keycode] -> String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Keycode]
ks)
    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
    MissingSource     Maybe Text
t   -> case Maybe Text
t of
      Just Text
t  -> String
"Reference to non-existent source: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t
      Maybe Text
Nothing -> String
"Reference to non-existent default source"
    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
    DuplicateLayerSetting Text
t Text
s -> String
"Duplicate setting in 'deflayer '"  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"': " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
s
    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
ImplArndDisabled      -> String
"Implicit around via `A` or `S-a` are disabled in your config"
    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

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

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

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

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

--------------------------------------------------------------------------------
-- $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 :: 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. (HasCallStack, Exception e) => e -> RIO e a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, 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 anything matching a particular prism from a list
extract :: Prism' a b -> [a] -> [b]
extract :: forall a b. Prism' a b -> [a] -> [b]
extract 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

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

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

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

-- | 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
  Maybe Int
ksd <- J (Maybe Int)
getKeySeqDelay

  -- 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 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
  let srcs :: [DefSrc]
srcs = Prism' KExpr DefSrc -> [KExpr] -> [DefSrc]
forall a b. Prism' a b -> [a] -> [b]
extract p DefSrc (f DefSrc) -> p KExpr (f KExpr)
forall r. AsKExpr r => Prism' r DefSrc
Prism' KExpr DefSrc
_KDefSrc [KExpr]
es
  (LMap Button
km, Text
fl) <- [DefSrc] -> [DefAlias] -> [DefLayer] -> J (LMap Button, Text)
joinKeymap [DefSrc]
srcs [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
    , _ksd :: Maybe Int
_ksd   = Maybe Int
ksd
    }

--------------------------------------------------------------------------------
-- $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
  -- FIXME: duplicates don't throw errors
  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 = [Text] -> 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)
        SImplArnd ImplArnd
ia -> 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 ImplArnd ImplArnd -> ImplArnd -> JCfg -> JCfg
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter JCfg JCfg ImplArnd ImplArnd
Lens' JCfg ImplArnd
implArnd ImplArnd
ia 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

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

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

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

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

-- | Extract the allow-cmd 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 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"

-- | Extract the cmp-seq-delay setting
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
0        -> 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
    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"

-- | Extract the key-seq-delay setting
getKeySeqDelay :: J (Maybe Int)
getKeySeqDelay :: J (Maybe Int)
getKeySeqDelay = 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
_SKeySeqDelay ([DefSetting] -> Either SingletonError Int)
-> [DefSetting] -> Either SingletonError Int
forall a b. (a -> b) -> a -> b
$ [DefSetting]
cfg of
    Right Int
0        -> 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
    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 (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1)
    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
"key-seq-delay"

#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 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"

-- | The Linux correspondence between OToken and actual code
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 = T.unpack t
                           , _postInit     = T.unpack <$> 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

-- | 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 di) = pure $ runLF (sendEventKeySink di)
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 :: [Text] -> [DefAlias] -> J Aliases
joinAliases [Text]
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 ([Text] -> Aliases -> DefButton -> J (Maybe Button)
joinButton [Text]
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 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
=<<)

fromImplArnd :: DefButton -> DefButton -> ImplArnd -> J DefButton
fromImplArnd :: DefButton -> DefButton -> ImplArnd -> J DefButton
fromImplArnd DefButton
_ DefButton
_ ImplArnd
IADisabled        = JoinError -> J DefButton
forall a. JoinError -> J a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError JoinError
ImplArndDisabled
fromImplArnd DefButton
o DefButton
i ImplArnd
IAAround          = DefButton -> J DefButton
forall a. a -> J a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DefButton -> J DefButton) -> DefButton -> J DefButton
forall a b. (a -> b) -> a -> b
$ DefButton -> DefButton -> DefButton
KAround DefButton
o DefButton
i
fromImplArnd DefButton
o DefButton
i ImplArnd
IAAroundOnly      = DefButton -> J DefButton
forall a. a -> J a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DefButton -> J DefButton) -> DefButton -> J DefButton
forall a b. (a -> b) -> a -> b
$ DefButton -> DefButton -> DefButton
KAroundOnly DefButton
o DefButton
i
fromImplArnd DefButton
o DefButton
i ImplArnd
IAAroundWhenAlone = DefButton -> J DefButton
forall a. a -> J a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DefButton -> J DefButton) -> DefButton -> J DefButton
forall a b. (a -> b) -> a -> b
$ DefButton -> DefButton -> DefButton
KAroundWhenAlone DefButton
o DefButton
i

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

  -- Define some utility functions
  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
. [Text] -> Aliases -> DefButton -> J (Maybe Button)
joinButton [Text]
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
    -- Variable dereference
    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

    -- Various simple buttons
    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 -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
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 -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
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 -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
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 -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
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 -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
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 -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
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

    -- Various compound buttons
    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
                             Maybe Button
csd' <- Maybe Int -> (Int -> J Button) -> J (Maybe Button)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe Int
csd ((Int -> J Button) -> J (Maybe Button))
-> (Int -> J Button) -> J (Maybe Button)
forall a b. (a -> b) -> a -> b
$ DefButton -> J Button
go (DefButton -> J Button) -> (Int -> DefButton) -> Int -> J Button
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
                             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])
-> ([Button] -> [Button]) -> [Button] -> [Button]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Button] -> [Button])
-> (Button -> [Button] -> [Button])
-> Maybe Button
-> [Button]
-> [Button]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Button] -> [Button]
forall a. a -> a
id (:) Maybe Button
csd' ([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
    KTapHoldNextPress 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
tapHoldNextPress (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
    KAroundOnly 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
aroundOnly         (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
    KAroundWhenAlone 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
aroundWhenAlone  (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
    KAroundImplicit DefButton
o DefButton
i  -> [Text] -> Aliases -> DefButton -> J (Maybe Button)
joinButton [Text]
ns Aliases
als (DefButton -> J (Maybe Button)) -> J DefButton -> J (Maybe Button)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DefButton -> DefButton -> ImplArnd -> J DefButton
fromImplArnd DefButton
o DefButton
i (ImplArnd -> J DefButton) -> J ImplArnd -> J DefButton
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Getting ImplArnd JCfg ImplArnd -> J ImplArnd
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ImplArnd JCfg ImplArnd
Lens' JCfg ImplArnd
implArnd
    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
    KStepped [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
steppedButton ([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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM DefButton -> J Button
go [DefButton]
bs
    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

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


--------------------------------------------------------------------------------
-- $src

type Sources = M.HashMap (Maybe Text) DefSrc

-- | Build up a hashmap of text to source mappings.
joinSources :: [DefSrc] -> J Sources
joinSources :: [DefSrc] -> J Sources
joinSources = (Sources -> DefSrc -> J Sources)
-> Sources -> [DefSrc] -> J Sources
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Sources -> DefSrc -> J Sources
joiner Sources
forall a. Monoid a => a
mempty
  where
   joiner :: Sources -> DefSrc -> J Sources
   joiner :: Sources -> DefSrc -> J Sources
joiner Sources
sources src :: DefSrc
src@DefSrc{ _srcName :: DefSrc -> Maybe Text
_srcName = Maybe Text
n, _keycodes :: DefSrc -> [Keycode]
_keycodes = [Keycode]
ks }
     | Maybe Text
n Maybe Text -> Sources -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
`M.member` Sources
sources = JoinError -> J Sources
forall a. JoinError -> J a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> J Sources) -> JoinError -> J Sources
forall a b. (a -> b) -> a -> b
$ Maybe Text -> JoinError
DuplicateSource Maybe Text
n
     | Bool -> Bool
not ([Keycode] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Keycode]
dups)      = JoinError -> J Sources
forall a. JoinError -> J a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> J Sources) -> JoinError -> J Sources
forall a b. (a -> b) -> a -> b
$ Maybe Text -> [Keycode] -> JoinError
DuplicateKeyInSource Maybe Text
n [Keycode]
dups
     | Bool
otherwise            = Sources -> J Sources
forall a. a -> J a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sources -> J Sources) -> Sources -> J Sources
forall a b. (a -> b) -> a -> b
$ Maybe Text -> DefSrc -> Sources -> Sources
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert Maybe Text
n DefSrc
src Sources
sources
    where
     dups :: [Keycode]
     dups :: [Keycode]
dups = ([Keycode] -> [Keycode]) -> [[Keycode]] -> [Keycode]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> [Keycode] -> [Keycode]
forall a. Int -> [a] -> [a]
take Int
1) ([[Keycode]] -> [Keycode])
-> ([Keycode] -> [[Keycode]]) -> [Keycode] -> [Keycode]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Keycode] -> Bool) -> [[Keycode]] -> [[Keycode]]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (Int -> Bool) -> ([Keycode] -> Int) -> [Keycode] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Keycode] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) ([[Keycode]] -> [[Keycode]])
-> ([Keycode] -> [[Keycode]]) -> [Keycode] -> [[Keycode]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Keycode] -> [[Keycode]]
forall a. Eq a => [a] -> [[a]]
group ([Keycode] -> [[Keycode]])
-> ([Keycode] -> [Keycode]) -> [Keycode] -> [[Keycode]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Keycode] -> [Keycode]
forall a. Ord a => [a] -> [a]
sort ([Keycode] -> [Keycode]) -> [Keycode] -> [Keycode]
forall a b. (a -> b) -> a -> b
$ [Keycode]
ks

--------------------------------------------------------------------------------
-- $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 []   [DefAlias]
_   [DefLayer]
_   = 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
"defsrc"
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]
srcs [DefAlias]
als [DefLayer]
lys = do
  let f :: [Text] -> Text -> m [Text]
f [Text]
acc Text
x = if Text
x Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
acc then JoinError -> m [Text]
forall a. JoinError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> m [Text]) -> JoinError -> m [Text]
forall a b. (a -> b) -> a -> b
$ Text -> JoinError
DuplicateLayer Text
x else [Text] -> m [Text]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
xText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
acc)
  [Text]
nms   <- ([Text] -> Text -> J [Text]) -> [Text] -> [Text] -> J [Text]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [Text] -> Text -> J [Text]
forall {m :: * -> *}.
MonadError JoinError m =>
[Text] -> Text -> m [Text]
f [] ([Text] -> J [Text]) -> [Text] -> J [Text]
forall a b. (a -> b) -> a -> b
$ (DefLayer -> Text) -> [DefLayer] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map DefLayer -> Text
_layerName [DefLayer]
lys     -- Extract all names
  Aliases
als'  <- [Text] -> [DefAlias] -> J Aliases
joinAliases [Text]
nms [DefAlias]
als                 -- Join aliases into 1 hashmap
  Sources
srcs' <- [DefSrc] -> J Sources
joinSources  [DefSrc]
srcs                   -- Join all sources 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Aliases
-> [Text] -> Sources -> DefLayer -> J (Text, [(Keycode, Button)])
joinLayer Aliases
als' [Text]
nms Sources
srcs') [DefLayer]
lys -- Join all layers
  -- Return the layerstack and the name of the first layer
  (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)

-- | Check and join 1 deflayer.
joinLayer ::
     Aliases                       -- ^ Mapping of names to buttons
  -> LNames                        -- ^ List of valid layer names
  -> Sources                       -- ^ Mapping of names to source layer
  -> DefLayer                      -- ^ The layer token to join
  -> J (Text, [(Keycode, Button)]) -- ^ The resulting tuple
joinLayer :: Aliases
-> [Text] -> Sources -> DefLayer -> J (Text, [(Keycode, Button)])
joinLayer Aliases
als [Text]
ns Sources
srcs l :: DefLayer
l@(DefLayer Text
n [DefLayerSetting]
settings) = do
  let bs :: [DefButton]
bs = [DefLayerSetting]
settings [DefLayerSetting]
-> Getting (Endo [DefButton]) [DefLayerSetting] DefButton
-> [DefButton]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (DefLayerSetting -> Const (Endo [DefButton]) DefLayerSetting)
-> [DefLayerSetting] -> Const (Endo [DefButton]) [DefLayerSetting]
forall s t a b. Each s t a b => Traversal s t a b
Traversal
  [DefLayerSetting] [DefLayerSetting] DefLayerSetting DefLayerSetting
each ((DefLayerSetting -> Const (Endo [DefButton]) DefLayerSetting)
 -> [DefLayerSetting] -> Const (Endo [DefButton]) [DefLayerSetting])
-> ((DefButton -> Const (Endo [DefButton]) DefButton)
    -> DefLayerSetting -> Const (Endo [DefButton]) DefLayerSetting)
-> Getting (Endo [DefButton]) [DefLayerSetting] DefButton
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DefButton -> Const (Endo [DefButton]) DefButton)
-> DefLayerSetting -> Const (Endo [DefButton]) DefLayerSetting
forall r. AsDefLayerSetting r => Prism' r DefButton
Prism' DefLayerSetting DefButton
_LButton
  Maybe Text
assocSrc <- DefLayer -> J (Maybe Text)
getAssocSrc DefLayer
l
  Maybe ImplArnd
implAround <- DefLayer -> J (Maybe ImplArnd)
getImplAround DefLayer
l

  [Keycode]
src <- case Maybe Text -> Sources -> Maybe DefSrc
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup Maybe Text
assocSrc Sources
srcs of
    Just DefSrc
src -> [Keycode] -> J [Keycode]
forall a. a -> J a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Keycode] -> J [Keycode]) -> [Keycode] -> J [Keycode]
forall a b. (a -> b) -> a -> b
$ DefSrc
srcDefSrc -> Getting [Keycode] DefSrc [Keycode] -> [Keycode]
forall s a. s -> Getting a s a -> a
^.Getting [Keycode] DefSrc [Keycode]
forall c. HasDefSrc c => Lens' c [Keycode]
Lens' DefSrc [Keycode]
keycodes
    Maybe DefSrc
Nothing  -> JoinError -> J [Keycode]
forall a. JoinError -> J a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> J [Keycode]) -> JoinError -> J [Keycode]
forall a b. (a -> b) -> a -> b
$ Maybe Text -> JoinError
MissingSource Maybe Text
assocSrc
  -- Ensure length-match between src and buttons
  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
/= [Keycode] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Keycode]
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) ([Keycode] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Keycode]
src)

  -- Join each button and add it (filtering out KTrans)
  let f :: [(Keycode, Button)]
-> (Keycode, DefButton) -> J [(Keycode, Button)]
f [(Keycode, Button)]
acc (Keycode
kc, DefButton
b) = [Text] -> Aliases -> DefButton -> J (Maybe Button)
joinButton [Text]
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
  (J (Text, [(Keycode, Button)]) -> J (Text, [(Keycode, Button)]))
-> (ImplArnd
    -> J (Text, [(Keycode, Button)]) -> J (Text, [(Keycode, Button)]))
-> Maybe ImplArnd
-> J (Text, [(Keycode, Button)])
-> J (Text, [(Keycode, Button)])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe J (Text, [(Keycode, Button)]) -> J (Text, [(Keycode, Button)])
forall a. a -> a
id ((JCfg -> JCfg)
-> J (Text, [(Keycode, Button)]) -> J (Text, [(Keycode, Button)])
forall a. (JCfg -> JCfg) -> J a -> J a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((JCfg -> JCfg)
 -> J (Text, [(Keycode, Button)]) -> J (Text, [(Keycode, Button)]))
-> (ImplArnd -> JCfg -> JCfg)
-> ImplArnd
-> J (Text, [(Keycode, Button)])
-> J (Text, [(Keycode, Button)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter JCfg JCfg ImplArnd ImplArnd -> ImplArnd -> JCfg -> JCfg
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter JCfg JCfg ImplArnd ImplArnd
Lens' JCfg ImplArnd
implArnd) Maybe ImplArnd
implAround (J (Text, [(Keycode, Button)]) -> J (Text, [(Keycode, Button)]))
-> J (Text, [(Keycode, Button)]) -> J (Text, [(Keycode, Button)])
forall a b. (a -> b) -> a -> b
$
    (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 [] ([Keycode] -> [DefButton] -> [(Keycode, DefButton)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Keycode]
src [DefButton]
bs)

getAssocSrc :: DefLayer -> J (Maybe Text)
getAssocSrc :: DefLayer -> J (Maybe Text)
getAssocSrc (DefLayer Text
n [DefLayerSetting]
settings) = case [Text] -> Either SingletonError Text
forall a. [a] -> Either SingletonError a
onlyOne ([DefLayerSetting]
settings [DefLayerSetting]
-> Getting (Endo [Text]) [DefLayerSetting] Text -> [Text]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (DefLayerSetting -> Const (Endo [Text]) DefLayerSetting)
-> [DefLayerSetting] -> Const (Endo [Text]) [DefLayerSetting]
forall s t a b. Each s t a b => Traversal s t a b
Traversal
  [DefLayerSetting] [DefLayerSetting] DefLayerSetting DefLayerSetting
each ((DefLayerSetting -> Const (Endo [Text]) DefLayerSetting)
 -> [DefLayerSetting] -> Const (Endo [Text]) [DefLayerSetting])
-> ((Text -> Const (Endo [Text]) Text)
    -> DefLayerSetting -> Const (Endo [Text]) DefLayerSetting)
-> Getting (Endo [Text]) [DefLayerSetting] Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const (Endo [Text]) Text)
-> DefLayerSetting -> Const (Endo [Text]) DefLayerSetting
forall r. AsDefLayerSetting r => Prism' r Text
Prism' DefLayerSetting Text
_LSrcName) of
  Right Text
x        -> Maybe Text -> J (Maybe Text)
forall a. a -> J a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> J (Maybe Text)) -> Maybe Text -> J (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
x
  Left SingletonError
None      -> Maybe Text -> J (Maybe Text)
forall a. a -> J a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
  Left SingletonError
Duplicate -> JoinError -> J (Maybe Text)
forall a. JoinError -> J a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> J (Maybe Text)) -> JoinError -> J (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> JoinError
DuplicateLayerSetting Text
n Text
"source"

getImplAround :: DefLayer -> J (Maybe ImplArnd)
getImplAround :: DefLayer -> J (Maybe ImplArnd)
getImplAround (DefLayer Text
n [DefLayerSetting]
settings) = case [ImplArnd] -> Either SingletonError ImplArnd
forall a. [a] -> Either SingletonError a
onlyOne ([DefLayerSetting]
settings [DefLayerSetting]
-> Getting (Endo [ImplArnd]) [DefLayerSetting] ImplArnd
-> [ImplArnd]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (DefLayerSetting -> Const (Endo [ImplArnd]) DefLayerSetting)
-> [DefLayerSetting] -> Const (Endo [ImplArnd]) [DefLayerSetting]
forall s t a b. Each s t a b => Traversal s t a b
Traversal
  [DefLayerSetting] [DefLayerSetting] DefLayerSetting DefLayerSetting
each ((DefLayerSetting -> Const (Endo [ImplArnd]) DefLayerSetting)
 -> [DefLayerSetting] -> Const (Endo [ImplArnd]) [DefLayerSetting])
-> ((ImplArnd -> Const (Endo [ImplArnd]) ImplArnd)
    -> DefLayerSetting -> Const (Endo [ImplArnd]) DefLayerSetting)
-> Getting (Endo [ImplArnd]) [DefLayerSetting] ImplArnd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ImplArnd -> Const (Endo [ImplArnd]) ImplArnd)
-> DefLayerSetting -> Const (Endo [ImplArnd]) DefLayerSetting
forall r. AsDefLayerSetting r => Prism' r ImplArnd
Prism' DefLayerSetting ImplArnd
_LImplArnd) of
  Right ImplArnd
x        -> Maybe ImplArnd -> J (Maybe ImplArnd)
forall a. a -> J a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ImplArnd -> J (Maybe ImplArnd))
-> Maybe ImplArnd -> J (Maybe ImplArnd)
forall a b. (a -> b) -> a -> b
$ ImplArnd -> Maybe ImplArnd
forall a. a -> Maybe a
Just ImplArnd
x
  Left SingletonError
None      -> Maybe ImplArnd -> J (Maybe ImplArnd)
forall a. a -> J a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ImplArnd
forall a. Maybe a
Nothing
  Left SingletonError
Duplicate -> JoinError -> J (Maybe ImplArnd)
forall a. JoinError -> J a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (JoinError -> J (Maybe ImplArnd))
-> JoinError -> J (Maybe ImplArnd)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> JoinError
DuplicateLayerSetting Text
n Text
"implicit-around"

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

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

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