Parser.hs

{-|
Module      : KMonad.Args.Parser
Description : How to turn a text-file into config-tokens
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 1.

-}
module KMonad.Args.Parser
  ( -- * Parsing 'KExpr's
    parseTokens
  , loadTokens

  -- * Building Parsers
  , symbol
  , keyword
  , sexpr
  , numP
  , mkTokenP'

  -- * Parsers for Tokens and Buttons
  , otokens
  , itokens
  , buttonP
  , buttonP'
  , implArndButtons
  , implArndP
  , keywordButtons
  , noKeywordButtons
  )
where

import KMonad.Prelude hiding (try, bool)

import KMonad.Parsing
import KMonad.Args.Types
import KMonad.Keyboard
import KMonad.Keyboard.ComposeSeq



import Data.Char
import RIO.List (find)


import qualified KMonad.Util.MultiMap as Q
import qualified RIO.Text as T
import qualified Text.Megaparsec.Char.Lexer as L

--------------------------------------------------------------------------------
-- $run

-- | Try to parse a list of 'KExpr' from 'Text'
parseTokens :: Text -> Either ParseError [KExpr]
parseTokens t = case runParser configP "" t  of
  Left  e -> Left $ ParseError e
  Right x -> Right x

-- | Load a set of tokens from file, throw an error on parse-fail
loadTokens :: FilePath -> RIO e [KExpr]
loadTokens pth = (readFileUtf8 pth <&> parseTokens) >>= \case
  Left e   -> throwM e
  Right xs -> pure xs


--------------------------------------------------------------------------------
-- $basic

-- | Consume whitespace after the provided parser
lexeme :: Parser a -> Parser a
lexeme = L.lexeme sc

-- | Consume 1 symbol
symbol :: Text -> Parser ()
symbol = void . L.symbol sc

-- | A predicate to check if a characters /ends/ a word or sequence
isDelimiter :: Char -> Bool
isDelimiter c = elem @[] c "()\"" || isSpace c

terminatorP :: Parser ()
terminatorP = void (satisfy isDelimiter) <|> eof <?> "end of token / delimiter"

-- | Consume all chars until a delimiter is encounterd
word :: Parser Text
word = lexeme . takeWhile1P Nothing $ not . isDelimiter

-- | Run the parser IFF it is terminated
terminated :: Parser a -> Parser a
terminated p = try . lexeme $ p <* lookAhead terminatorP

-- | Keywords are terminated symbols
keyword :: Text -> Parser ()
keyword = terminated . void . string -- `string` intead of `symbol`, since `terminated` already does `lexeme`

keyword' :: Text -> a -> Parser a
keyword' k x = keyword k $> x

-- | Run a parser designed to parse an inner S-expression.
sexpr :: Text -> Parser a -> Parser a
sexpr s p = keyword s *> p

-- | Create a parser that matches symbols to values and only consumes on match.
fromNamed :: [(Text, a)] -> Parser a
fromNamed = choice . map (uncurry keyword')

-- | Run a parser between 2 sets of parentheses
paren :: Parser a -> Parser a
paren = between (symbol "(") (symbol ")")

-- | Run a parser that parser a bool value
boolP :: Parser Bool
boolP = keyword' "true" True <|> keyword' "false" False

-- | Parse an option argument of the form @:keyword value@
optargP :: Text -> Parser p -> Parser p
optargP a p = keyword (":" <> a) *> p
  <?> "Keyword " <> ":" <> unpack a

optarg'P :: Text -> Parser p -> Parser (Maybe p)
optarg'P a = optional . optargP a

-- | Parse based on a liste of sexpressions
mkTokenP :: [(Text, Parser a)] -> Parser a
mkTokenP = mkTokenP' False

mkTokenP' :: Bool -> [(Text, Parser a)] -> Parser a
mkTokenP' toplevel tkns = paren' . choice $ uncurry sexpr <$> tkns
 where
  paren' = if toplevel then id else paren

--------------------------------------------------------------------------------
-- $elem
--
-- Parsers for elements that are not stand-alone KExpr's

-- | Parse a keycode
keycodeP :: Parser Keycode
keycodeP = fromNamed (Q.reverse keyNames ^.. Q.itemed) <?> "keycode"

-- | Parse an integer
numP :: Parser Int
numP = terminated L.decimal

-- | Parse text with escaped characters between double quotes.
textP :: Parser Text
textP = lexeme $ char '"' >> pack <$> manyTill L.charLiteral (char '"')

-- | Parse a variable reference
derefP :: Parser Text
derefP = char '@' *> word

--------------------------------------------------------------------------------
-- $cmb
--
-- Parsers built up from the basic KExpr's

-- | Consume an entire file of expressions and comments
configP :: Parser [KExpr]
configP = sc *> exprsP <* eof

-- | Parse 0 or more KExpr's
exprsP :: Parser [KExpr]
exprsP = many exprP

-- | Parse 1 KExpr
exprP :: Parser KExpr
exprP = paren . choice $
  [ sexpr "defcfg"    $ KDefCfg   <$> defcfgP
  , sexpr "defsrc"    $ KDefSrc   <$> defsrcP
  , sexpr "deflayer"  $ KDefLayer <$> deflayerP
  , sexpr "defalias"  $ KDefAlias <$> defaliasP
  ]

--------------------------------------------------------------------------------
-- $but
--
-- All the various ways to refer to buttons

shifted :: Keycode -> DefButton
shifted = KAroundImplicit (KEmit KeyLeftShift) . KEmit

-- | Different ways to refer to shifted versions of keycodes
shiftedNames :: [(Text, DefButton)]
shiftedNames = second shifted <$> cps <> num <> oth <> lng
  where
    cps = zip (map T.singleton ['A'..'Z'])
          [ KeyA, KeyB, KeyC, KeyD, KeyE, KeyF, KeyG, KeyH, KeyI, KeyJ, KeyK, KeyL, KeyM,
            KeyN, KeyO, KeyP, KeyQ, KeyR, KeyS, KeyT, KeyU, KeyV, KeyW, KeyX, KeyY, KeyZ ]
    num = zip (map T.singleton "!@#$%^&*")
          [ Key1, Key2, Key3, Key4, Key5, Key6, Key7, Key8 ]
    oth = zip (map T.singleton "<>:~\"|{}+?")
          [ KeyComma, KeyDot, KeySemicolon, KeyGrave, KeyApostrophe, KeyBackslash
          , KeyLeftBrace, KeyRightBrace, KeyEqual, KeySlash]
    lng = [ ("quot", KeyApostrophe), ("pipe", KeyBackslash), ("cln", KeySemicolon)
          , ("tild", KeyGrave) , ("udrs", KeyMinus)]

-- | Names for various buttons
buttonNames :: [(Text, DefButton)]
buttonNames = shiftedNames <> escp <> util
  where
    -- Escaped versions for reserved characters
    escp = [ ("\\(", shifted Key9), ("\\)", shifted Key0)
           , ("\\_", shifted KeyMinus), ("\\\\", KEmit KeyBackslash)]
    -- Extra names for useful buttons
    util = [ ("_", KTrans), ("XX", KBlock)
           , ("lprn", shifted Key9), ("rprn", shifted Key0)]

-- | Parse "X-b" style modded-sequences
moddedP :: Parser DefButton
moddedP = KAroundImplicit <$> prfx <*> buttonP
  where mods = [ ("S-", KeyLeftShift), ("C-", KeyLeftCtrl)
               , ("A-", KeyLeftAlt),   ("M-", KeyLeftMeta)
               , ("RS-", KeyRightShift), ("RC-", KeyRightCtrl)
               , ("RA-", KeyRightAlt),   ("RM-", KeyRightMeta)]
        prfx = choice $ map (\(t, p) -> try $ string t $> KEmit p) mods

-- | Parse Pxxx as pauses (useful in macros)
pauseP :: Parser DefButton
pauseP = KPause . fromIntegral <$> (char 'P' *> numP)

-- | #()-syntax tap-macro
rmTapMacroP :: Parser DefButton
rmTapMacroP =
  try (symbol "#(")
    >> KTapMacro <$> some buttonP <*> optarg'P "delay" numP
    <* symbol ")"

-- | Compose-key sequence
composeSeqP :: Parser [DefButton]
composeSeqP = do
  -- Lookup 1 character in the compose-seq list
  s <- terminated $ do
    c <- anySingle <?> "special character"
    case find (\(_, c', _) -> c' == c) ssComposed of
      Nothing -> fail "Unrecognized compose-char"
      Just b  -> pure $ b^._1

  -- If matching, parse a button-sequence from the stored text
  case runParser (some buttonP <* eof) "" s of
    Left  _ -> fail $ "Internal error: Could not parse compose sequence `" <> unpack s <> "`"
    Right b -> pure b

-- | Parse a dead-key sequence as a `+` followed by some symbol
deadkeySeqP :: Parser [DefButton]
deadkeySeqP = do
  c <- terminated $ char '+' *> satisfy (`elem` ("~'^`\"," :: String))

  case runParser buttonP "" (T.singleton c) of
    Left  _ -> fail $ "Internal error: Could not parse deadkey sequence `" <> [c] <> "`"
    Right b -> pure [b]

-- | Parse any button
buttonP :: Parser DefButton
buttonP = buttonP' False

buttonP' :: Bool -> Parser DefButton
buttonP' toplevel = mkTokenP' toplevel keywordButtons <|> choice noKeywordButtons <?> "button"

-- | Parsers for buttons that have a keyword at the start; the format is
-- @(keyword, how to parse the token)@
keywordButtons :: [(Text, Parser DefButton)]
keywordButtons =
  [ (,) "around-implicit"          $ KAroundImplicit        <$> buttonP  <*> buttonP
  , (,) "press-only"               $ KPressOnly             <$> keycodeP
  , (,) "release-only"             $ KReleaseOnly           <$> keycodeP
  , (,) "multi-tap"                $ KMultiTap              <$> timed    <*> buttonP
  , (,) "stepped"                  $ KStepped               <$> buttonsP
  , (,) "tap-hold"                 $ KTapHold               <$> numP     <*> buttonP <*> buttonP
  , (,) "tap-hold-next"            $ KTapHoldNext           <$> numP     <*> buttonP <*> buttonP <*> timeoutP
  , (,) "tap-next-release"         $ KTapNextRelease        <$> buttonP  <*> buttonP
  , (,) "tap-hold-next-release"    $ KTapHoldNextRelease    <$> numP     <*> buttonP <*> buttonP <*> timeoutP
  , (,) "tap-next-press"           $ KTapNextPress          <$> buttonP  <*> buttonP
  , (,) "tap-hold-next-press"      $ KTapHoldNextPress      <$> numP     <*> buttonP <*> buttonP <*> timeoutP
  , (,) "tap-next"                 $ KTapNext               <$> buttonP  <*> buttonP
  , (,) "layer-toggle"             $ KLayerToggle           <$> word
  , (,) "momentary-layer"          $ KLayerToggle           <$> word
  , (,) "layer-switch"             $ KLayerSwitch           <$> word
  , (,) "permanent-layer"          $ KLayerSwitch           <$> word
  , (,) "layer-add"                $ KLayerAdd              <$> word
  , (,) "layer-rem"                $ KLayerRem              <$> word
  , (,) "layer-delay"              $ KLayerDelay            <$> numP     <*> word
  , (,) "layer-next"               $ KLayerNext             <$> word
  , (,) "around-next"              $ KAroundNext            <$> buttonP
  , (,) "around-next-single"       $ KAroundNextSingle      <$> buttonP
  , (,) "before-after-next"        $ KBeforeAfterNext       <$> buttonP  <*> buttonP
  , (,) "around-next-timeout"      $ KAroundNextTimeout     <$> numP     <*> buttonP <*> buttonP
  , (,) "tap-macro"                $ KTapMacro              <$> buttonsP <*> delayP
  , (,) "tap-macro-release"        $ KTapMacroRelease       <$> buttonsP <*> delayP
  , (,) "cmd-button"               $ KCommand               <$> textP    <*> optional textP
  , (,) "pause"                    $ kPause                 <$> numP
  , (,) "sticky-key"               $ KStickyKey             <$> numP     <*> buttonP
  ]
  ++ map (\(nm,_,btn) -> (nm, btn <$> buttonP <*> buttonP)) implArndButtons
 where
  timed :: Parser [(Int, DefButton)]
  timed = many ((,) <$> numP <*> buttonP)
  kPause = KPause . fromIntegral
  buttonsP = some buttonP
  timeoutP = optarg'P "timeout-button" buttonP
  delayP   = optarg'P "delay" numP

implArndButtons :: [(Text, ImplArnd, DefButton -> DefButton -> DefButton)]
implArndButtons =
  [ ("around"           , IAAround         , KAround)
  , ("around-only"      , IAAroundOnly     , KAroundOnly)
  , ("around-when-alone", IAAroundWhenAlone, KAroundWhenAlone)
  ]

-- | Parsers for buttons that do __not__ have a keyword at the start
noKeywordButtons :: [Parser DefButton]
noKeywordButtons =
  [ KComposeSeq <$> deadkeySeqP
  , rmTapMacroP
  , fromNamed buttonNames
  , KRef  <$> derefP
  , moddedP
  , pauseP
  , KEmit <$> keycodeP
  , KComposeSeq <$> composeSeqP
  ]

--------------------------------------------------------------------------------
-- $defcfg

-- | Parse an input token
itokenP :: Parser IToken
itokenP = mkTokenP itokens

-- | Input tokens to parse; the format is @(keyword, how to parse the token)@
itokens :: [(Text, Parser IToken)]
itokens =
  [ ("device-file"   , KDeviceSource . unpack <$> textP <*> ignoreMissingP)
  , ("low-level-hook", pure KLowLevelHookSource)
  , ("iokit-name"    , KIOKitSource <$> optional textP)
  ]
 where
  ignoreMissingP = option False $ optargP "ignore-missing" boolP

-- | Parse an output token
otokenP :: Parser OToken
otokenP = mkTokenP otokens

-- | Output tokens to parse; the format is @(keyword, how to parse the token)@
otokens :: [(Text, Parser OToken)]
otokens =
  [ ("uinput-sink"    , KUinputSink <$> textP <*> optional textP)
  , ("send-event-sink", KSendEventSink <$> optional ((,) <$> numP <*> numP))
  , ("kext"           , pure KKextSink)
  ]

-- | Parse an impl arnd token
implArndP :: Parser ImplArnd
implArndP = choice $
  keyword' "disabled" IADisabled
  : map (\(s, v, _) -> keyword' s v) implArndButtons

-- | Parse the DefCfg token
defcfgP :: Parser DefSettings
defcfgP = some settingP

-- | All possible configuration options that can be passed in the defcfg block
settingP :: Parser DefSetting
settingP =
  choice
    [ SIToken      <$> sexpr "input"         itokenP
    , SOToken      <$> sexpr "output"        otokenP
    , SCmpSeq      <$> sexpr "cmp-seq"       buttonP
    , SFallThrough <$> sexpr "fallthrough"   boolP
    , SAllowCmd    <$> sexpr "allow-cmd"     boolP
    , SCmpSeqDelay <$> sexpr "cmp-seq-delay" numP
    , SKeySeqDelay <$> sexpr "key-seq-delay" numP
    , SImplArnd    <$> sexpr "implicit-around" implArndP
    ]

--------------------------------------------------------------------------------
-- $defalias

-- | Parse a collection of names and buttons
defaliasP :: Parser DefAlias
defaliasP = many $ (,) <$> word <*> buttonP

--------------------------------------------------------------------------------
-- $defsrc

defsrcP :: Parser DefSrc
defsrcP =
  DefSrc
    <$> optarg'P "name" word
    <*> many buttonP

--------------------------------------------------------------------------------
-- $deflayer

deflayerP :: Parser DefLayer
deflayerP = DefLayer <$> word <*> many layerSettingP

layerSettingP :: Parser DefLayerSetting
layerSettingP =
  choice
    [ LSrcName   <$> optargP "source" word
    , LImplArnd  <$> optargP "implicit-around" implArndP
    , LButton    <$> buttonP
    ]