Joiner.hs

{-# 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.Util

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, find)
import RIO.Partial (fromJust)
import qualified KMonad.Util.LayerStack  as L
import qualified RIO.NonEmpty     as NE
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
  | CyclicAlias      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
  | NotAKeycode      DefButton

instance Show JoinError where
  show e = case e of
    DuplicateBlock    t   -> "Encountered duplicate block of type: " <> T.unpack t
    MissingBlock      t   -> "Missing at least 1 block of type: "    <> T.unpack t
    DuplicateAlias    t   -> "Multiple aliases of the same name: "   <> T.unpack t
    CyclicAlias       t   -> "Aliases references itself in a loop: " <> T.unpack t
    DuplicateLayer    t   -> "Multiple layers of the same name: "    <> T.unpack t
    DuplicateSource   t   -> case t of
      Just t  -> "Multiple sources of the same name: " <> T.unpack t
      Nothing -> "Multiple default sources"
    DuplicateKeyInSource   t ks   -> case t of
      Just t  -> "Keycodes appear multiple times in source `" <> T.unpack t <> "`:" <> ((' ' :) . show =<< ks)
      Nothing -> "Keycodes appear multiple times in default source: " <> ((' ' :) . show =<< ks)
    MissingAlias      t   -> "Reference to non-existent alias: "     <> T.unpack t
    MissingLayer      t   -> "Reference to non-existent layer: "     <> T.unpack t
    MissingSource     t   -> case t of
      Just t  -> "Reference to non-existent source: " <> T.unpack t
      Nothing -> "Reference to non-existent default source"
    MissingSetting    t   -> "Missing setting in 'defcfg': "         <> T.unpack t
    DuplicateSetting  t   -> "Duplicate setting in 'defcfg': "       <> T.unpack t
    DuplicateLayerSetting t s -> "Duplicate setting in 'deflayer '"  <> T.unpack t <> "': " <> T.unpack s
    InvalidOS         t   -> "Not available under this OS: "         <> T.unpack t
    ImplArndDisabled      -> "Implicit around via `A` or `S-a` are disabled in your config"
    NestedTrans           -> "Encountered 'Transparent' outside of top-level layer"
    InvalidComposeKey     -> "Encountered invalid button as Compose key"
    LengthMismatch t l s  -> mconcat
      [ "Mismatch between length of 'defsrc' and deflayer <", T.unpack t, ">\n"
      , "Source length: ", show s, "\n"
      , "Layer length: ", show l ]
    NotAKeycode       b   -> "Encountered non keycode button in 'defsrc': " <> show b


instance Exception JoinError

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

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

-- | Monad in which we join, just Except over Reader
newtype J a = J { unJ :: ExceptT JoinError (Reader JCfg) a }
  deriving ( Functor, Applicative, Monad
           , MonadError JoinError , MonadReader JCfg)

-- | Perform a joining computation
runJ :: J a -> JCfg -> Either JoinError a
runJ j = runReader (runExceptT $ unJ 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 es = case runJ joinConfig $ defJCfg es of
  Left  e -> throwM e
  Right c -> pure c

-- | Extract anything matching a particular prism from a list
extract :: Prism' a b -> [a] -> [b]
extract p = mapMaybe (preview p)

data SingletonError
  = None
  | Duplicate

-- | Take the head of a list, or else throw the appropriate error
onlyOne :: [a] -> Either SingletonError a
onlyOne xs = case uncons xs of
  Just (x, []) -> Right x
  Just _       -> Left Duplicate
  Nothing      -> Left None

-- | Take the one and only block matching the prism from the expressions
oneBlock :: Text -> Prism' KExpr a -> J a
oneBlock t l = (view kes <&> (extract l >>> onlyOne)) >>= \case
  Right x        -> pure x
  Left None      -> throwError $ MissingBlock t
  Left Duplicate -> throwError $ DuplicateBlock t

-- | Update the JCfg and then run the entire joining process
joinConfig :: J CfgToken
joinConfig = getOverride >>= \cfg -> local (const cfg) joinConfig'

-- | Join an entire 'CfgToken' from the current list of 'KExpr'.
joinConfig' :: J CfgToken
joinConfig' = do

  es <- view kes

  -- Extract the IO settings
  i  <- getI
  o  <- getO
  ft <- getFT
  al <- getAllow
  ksd <- getKeySeqDelay

  -- Extract the other blocks and join them into a keymap
  let als = extract _KDefAlias es
  let lys = extract _KDefLayer es
  let srcs = extract _KDefSrc es
  (km, fl) <- joinKeymap srcs als lys

  pure $ CfgToken
    { _snk   = o
    , _src   = i
    , _km    = km
    , _fstL  = fl
    , _flt   = ft
    , _allow = al
    , _ksd   = 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 = do
  -- FIXME: duplicates don't throw errors
  env <- ask
  cfg <- oneBlock "defcfg" _KDefCfg
  let getB = joinButton [] M.empty
  let go e v = case v of
        SCmpSeq b  -> getB b >>= maybe (throwError InvalidComposeKey)
                                       (\b' -> pure $ set cmpKey b' e)
        SImplArnd ia -> pure $ set implArnd ia e
        _ -> pure e
  foldM go env cfg

-- | Turn a 'HasLogFunc'-only RIO into a function from LogFunc to IO
runLF :: HasLogFunc lf => RIO lf a -> lf -> IO a
runLF = flip runRIO

-- | Extract the KeySource-loader from the 'KExpr's
getI :: J (LogFunc -> IO (Acquire KeySource))
getI = do
  cfg <- oneBlock "defcfg" _KDefCfg
  case onlyOne . extract _SIToken $ cfg of
    Right i          -> pickInput i
    Left  None       -> throwError $ MissingSetting "input"
    Left  Duplicate  -> throwError $ DuplicateSetting "input"

-- | Extract the KeySource-loader from a 'KExpr's
getO :: J (LogFunc -> IO (Acquire KeySink))
getO = do
  cfg <- oneBlock "defcfg" _KDefCfg
  case onlyOne . extract _SOToken $ cfg of
    Right o         -> pickOutput o
    Left  None      -> throwError $ MissingSetting "output"
    Left  Duplicate -> throwError $ DuplicateSetting "output"

-- | Extract the fallthrough setting
getFT :: J Bool
getFT = do
  cfg <- oneBlock "defcfg" _KDefCfg
  case onlyOne . extract _SFallThrough $ cfg of
    Right b        -> pure b
    Left None      -> pure False
    Left Duplicate -> throwError $ DuplicateSetting "fallthrough"

-- | Extract the allow-cmd setting
getAllow :: J Bool
getAllow = do
  cfg <- oneBlock "defcfg" _KDefCfg
  case onlyOne . extract _SAllowCmd $ cfg of
    Right b        -> pure b
    Left None      -> pure False
    Left Duplicate -> throwError $ DuplicateSetting "allow-cmd"

-- | Extract the cmp-seq-delay setting
getCmpSeqDelay :: J (Maybe Int)
getCmpSeqDelay = do
  cfg <- oneBlock "defcfg" _KDefCfg
  case onlyOne . extract _SCmpSeqDelay $ cfg of
    Right 0        -> pure Nothing
    Right b        -> pure (Just b)
    Left None      -> pure Nothing
    Left Duplicate -> throwError $ DuplicateSetting "cmp-seq-delay"

-- | Extract the key-seq-delay setting
getKeySeqDelay :: J (Maybe Int)
getKeySeqDelay = do
  cfg <- oneBlock "defcfg" _KDefCfg
  case onlyOne . extract _SKeySeqDelay $ cfg of
    Right 0        -> pure Nothing
    Right b        -> pure (Just b)
    Left None      -> pure (Just 1)
    Left Duplicate -> throwError $ DuplicateSetting "key-seq-delay"

#ifdef linux_HOST_OS

-- | The Linux correspondence between IToken and actual code
pickInput :: IToken -> J (LogFunc -> IO (Acquire KeySource))
pickInput (KDeviceSource f im) = pure $ runLF (deviceSource64 f im)
pickInput KLowLevelHookSource = throwError $ InvalidOS "LowLevelHookSource"
pickInput (KIOKitSource _)    = throwError $ InvalidOS "IOKitSource"

-- | The Linux correspondence between OToken and actual code
pickOutput :: OToken -> J (LogFunc -> IO (Acquire KeySink))
pickOutput (KUinputSink t init) = pure $ runLF (uinputSink cfg)
  where cfg = defUinputCfg { _keyboardName = T.unpack t
                           , _postInit     = T.unpack <$> init }
pickOutput (KSendEventSink _)   = throwError $ InvalidOS "SendEventSink"
pickOutput KKextSink            = throwError $ 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 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 DefButton
type LNames  = [Text]

-- | Build up a hashmap of text to button mappings
--
-- Aliases can refer back to other aliases.
joinAliases :: [DefAlias] -> J Aliases
joinAliases als = do
  let als' = concat als
  case find (not . null . NE.tail) $ NE.groupAllWith fst als' of
    Nothing -> pure ()
    Just ((t, _) :| _) -> throwError $ DuplicateAlias t

  M.traverseWithKey =<< go $ M.fromList als'
 where
  go mp t b@(KRef t')
    | t == t' = throwError $ CyclicAlias t
    | otherwise = withDerefAlias mp (go mp t) b
  go _ _ b = pure b

withDerefAlias :: Aliases -> (DefButton -> J a) -> DefButton -> J a
withDerefAlias als f (KRef t) = case M.lookup t als of
  Just b -> f b
  Nothing -> throwError $ MissingAlias t
withDerefAlias _ f b = f 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 = (maybe (throwError NestedTrans) pure =<<)

fromImplArnd :: DefButton -> DefButton -> ImplArnd -> J DefButton
fromImplArnd _ _ IADisabled        = throwError ImplArndDisabled
fromImplArnd o i IAAround          = pure $ KAround o i
fromImplArnd o i IAAroundOnly      = pure $ KAroundOnly o i
fromImplArnd o i IAAroundWhenAlone = pure $ KAroundWhenAlone o i

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

  -- Define some utility functions
  let ret    = pure . Just
      go     = unnest . joinButton ns als
      jst    = fmap Just
      fi     = fromIntegral
      isps l = traverse go . maybe l ((`intersperse` l) . KPause . fi)
  in \case
    -- Variable dereference
    b@(KRef _) -> withDerefAlias als (joinButton ns als) b

    -- Various simple buttons
    KEmit c -> ret $ emitB c
    KPressOnly c -> ret $ pressOnly c
    KReleaseOnly c -> ret $ releaseOnly c
    KCommand pr mbR -> ret $ cmdButton pr mbR
    KLayerToggle t -> if t `elem` ns
      then ret $ layerToggle t
      else throwError $ MissingLayer t
    KLayerSwitch t -> if t `elem` ns
      then ret $ layerSwitch t
      else throwError $ MissingLayer t
    KLayerAdd t -> if t `elem` ns
      then ret $ layerAdd t
      else throwError $ MissingLayer t
    KLayerRem t -> if t `elem` ns
      then ret $ layerRem t
      else throwError $ MissingLayer t
    KLayerDelay s t -> if t `elem` ns
      then ret $ layerDelay (fi s) t
      else throwError $ MissingLayer t
    KLayerNext t -> if t `elem` ns
      then ret $ layerNext t
      else throwError $ MissingLayer t

    -- Various compound buttons
    KComposeSeq bs     -> do csd <- getCmpSeqDelay
                             c   <- view cmpKey
                             csd' <- for csd $ go . KPause . fi
                             jst $ tapMacro . (c:) . maybe id (:) csd' <$> isps bs csd
    KTapMacro bs mbD   -> jst $ tapMacro           <$> isps bs mbD
    KBeforeAfterNext b a -> jst $ beforeAfterNext <$> go b <*> go a
    KTapMacroRelease bs mbD ->
      jst $ tapMacroRelease           <$> isps bs mbD
    KAround o i        -> jst $ around             <$> go o <*> go i
    KTapNext t h       -> jst $ tapNext            <$> go t <*> go h
    KTapHold s t h     -> jst $ tapHold (fi s)     <$> go t <*> go h
    KTapHoldNext s t h mtb
      -> jst $ tapHoldNext (fi s) <$> go t <*> go h <*> traverse go mtb
    KTapNextRelease t h -> jst $ tapNextRelease    <$> go t <*> go h
    KTapHoldNextRelease ms t h mtb
      -> jst $ tapHoldNextRelease (fi ms) <$> go t <*> go h <*> traverse go mtb
    KTapNextPress t h  -> jst $ tapNextPress       <$> go t <*> go h
    KTapHoldNextPress ms t h mtb
      -> jst $ tapHoldNextPress (fi ms) <$> go t <*> go h <*> traverse go mtb
    KAroundOnly o i    -> jst $ aroundOnly         <$> go o <*> go i
    KAroundWhenAlone o i -> jst $ aroundWhenAlone  <$> go o <*> go i
    KAroundImplicit o i  -> joinButton ns als =<< fromImplArnd o i =<< view implArnd
    KAroundNext b      -> jst $ aroundNext         <$> go b
    KAroundNextSingle b -> jst $ aroundNextSingle <$> go b
    KAroundNextTimeout ms b t -> jst $ aroundNextTimeout (fi ms) <$> go b <*> go t
    KPause ms          -> jst . pure $ onPress (pause ms)
    KMultiTap bs d     -> jst $ multiTap <$> go d <*> mapM f bs
      where f (ms, b) = (fi ms,) <$> go b
    KStepped bs        -> jst $ steppedButton <$> mapM go bs
    KStickyKey s d     -> jst $ stickyKey (fi s) <$> go d

    -- Non-action buttons
    KTrans -> pure Nothing
    KBlock -> ret pass


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

type Sources = M.HashMap (Maybe Text) [Maybe Keycode]

-- | Build up a hashmap of text to source mappings.
joinSources :: Aliases -> [DefSrc] -> J Sources
joinSources als = foldM joiner mempty
  where
   joiner :: Sources -> DefSrc -> J Sources
   joiner sources DefSrc{ _srcName = n, _keycodes = ks }
     | n `M.member` sources = throwError $ DuplicateSource n
     | otherwise            = do
        ks' <- for ks $ withDerefAlias als joinKeycode
        let dups = NE.head <$> duplicatesWith id (toList =<< ks')
        unless (null dups) $ throwError $ DuplicateKeyInSource n dups
        pure $ M.insert n ks' sources
    where
     joinKeycode (KEmit k) = pure $ Just k
     joinKeycode KBlock    = pure Nothing
     joinKeycode b         = throwError $ NotAKeycode b

--------------------------------------------------------------------------------
-- $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 []   _   _   = throwError $ MissingBlock "defsrc"
joinKeymap _    _   []  = throwError $ MissingBlock "deflayer"
joinKeymap srcs als lys = do
  let f acc x = if x `elem` acc then throwError $ DuplicateLayer x else pure (x:acc)
  nms   <- foldM f [] $ map _layerName lys     -- Extract all names
  als'  <- joinAliases als                     -- Join aliases into 1 hashmap
  srcs' <- joinSources als' srcs               -- Join all sources into 1 hashmap
  lys'  <- mapM (joinLayer als' nms srcs') lys -- Join all layers
  -- Return the layerstack and the name of the first layer
  pure (L.mkLayerStack lys', _layerName . fromJust . headMaybe $ 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 als ns srcs l@(DefLayer n settings) = do
  let bs = settings ^.. each . _LButton
  assocSrc <- getAssocSrc l
  implAround <- getImplAround l

  src <- case M.lookup assocSrc srcs of
    Just src -> pure src
    Nothing  -> throwError $ MissingSource assocSrc
  -- Ensure length-match between src and buttons
  when (length bs /= length src) $
    throwError $ LengthMismatch n (length bs) (length src)

  -- Join each button and add it (filtering out KTrans)
  let
    f acc (Nothing, b) = joinButton ns als b $> acc
    f acc (Just kc, b) = joinButton ns als b >>= \case
      Nothing -> pure acc
      Just b' -> pure $ (kc, b') : acc
  maybe id (local . set implArnd) implAround $
    (n,) <$> foldM f [] (zip src bs)

getAssocSrc :: DefLayer -> J (Maybe Text)
getAssocSrc (DefLayer n settings) = case onlyOne (settings ^.. each . _LSrcName) of
  Right x        -> pure $ Just x
  Left None      -> pure Nothing
  Left Duplicate -> throwError $ DuplicateLayerSetting n "source"

getImplAround :: DefLayer -> J (Maybe ImplArnd)
getImplAround (DefLayer n settings) = case onlyOne (settings ^.. each . _LImplArnd) of
  Right x        -> pure $ Just x
  Left None      -> pure Nothing
  Left Duplicate -> throwError $ DuplicateLayerSetting n "implicit-around"

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

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

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