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
  , numP

  -- * Parsers for Tokens and Buttons
  , otokens
  , itokens
  , buttonP
  , implArndButtons
  , 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 (sortBy, 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

-- | List of all characters that /end/ a word or sequence
terminators :: String
terminators = ")\""

terminatorP :: Parser Char
terminatorP = satisfy (`elem` terminators)

-- | Consume all chars until a space is encounterd
word :: Parser Text
word = T.pack <$> some (satisfy wordChar)
  where wordChar c = not (isSpace c || c `elem` terminators)

-- | Run the parser IFF it is followed by a space, eof, or reserved char
terminated :: Parser a -> Parser a
terminated p = try $ p <* lookAhead (void spaceChar <|> eof <|> void terminatorP)

-- | Run the parser IFF it is not followed by a space or eof.
prefix :: Parser a -> Parser a
prefix p = try $ p <* notFollowedBy (void spaceChar <|> eof)

-- | Create a parser that matches symbols to values and only consumes on match.
fromNamed :: [(Text, a)] -> Parser a
fromNamed = choice . map mkOne . srt
  where
    -- | Sort descending by length of key and then alphabetically
    srt :: [(Text, b)] -> [(Text, b)]
    srt = sortBy . flip on fst $ \a b ->
      case compare (T.length b) (T.length a) of
        EQ -> compare a b
        x  -> x

    -- | Make a parser that matches a terminated symbol or fails
    mkOne (s, x) = terminated (string s) $> x

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

-- | Run a parser between 2 sets of parentheses starting with a symbol
statement :: Text -> Parser a -> Parser a
statement s = paren . (symbol s *>)

-- | Run a parser that parser a bool value
bool :: Parser Bool
bool = (symbol "true"  $> True)
   <|> (symbol "false" $> False)

-- | Parse a LISP-like keyword of the form @:keyword value@
keywordP :: Text -> Parser p -> Parser p
keywordP kw p = symbol (":" <> kw) *> lexeme p
  <?> "Keyword " <> ":" <> T.unpack kw

--------------------------------------------------------------------------------
-- $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 = L.decimal

-- | Parse text with escaped characters between double quotes.
textP :: Parser Text
textP = do
  _ <- char '\"'
  s <- manyTill L.charLiteral (char '\"')
  pure . T.pack $ s

-- | Parse a variable reference
derefP :: Parser Text
derefP = prefix (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 = lexeme . many $ lexeme exprP

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

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

-- | Different ways to refer to shifted versions of keycodes
shiftedNames :: [(Text, DefButton)]
shiftedNames = let f = second $ \kc -> KAroundImplicit (KEmit KeyLeftShift) (KEmit kc) in
                 map f $ 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
    emitS c = KAroundImplicit (KEmit KeyLeftShift) (KEmit c)
    -- Escaped versions for reserved characters
    escp = [ ("\\(", emitS Key9), ("\\)", emitS Key0)
           , ("\\_", emitS KeyMinus), ("\\\\", KEmit KeyBackslash)]
    -- Extra names for useful buttons
    util = [ ("_", KTrans), ("XX", KBlock)
           , ("lprn", emitS Key9), ("rprn", emitS 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) -> prefix (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 =
  char '#' *> paren (KTapMacro <$> some buttonP
                               <*> optional (keywordP "delay" numP))

-- | Compose-key sequence
composeSeqP :: Parser [DefButton]
composeSeqP = do
  -- Lookup 1 character in the compose-seq list
  c <- anySingle <?> "special character"
  s <- 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) "" s of
    -- Parse error never reaches the user. They simply get a message about an unexpected character.
    Left  _ -> fail "Could not parse compose sequence"
    Right b -> pure b

-- | Parse a dead-key sequence as a `+` followed by some symbol
deadkeySeqP :: Parser [DefButton]
deadkeySeqP = do
  _ <- prefix (char '+')
  c <- satisfy (`elem` ("~'^`\"," :: String))
  case runParser buttonP "" (T.singleton c) of
    Left  _ -> fail "Could not parse deadkey sequence"
    Right b -> pure [b]

-- | Parse any button
buttonP :: Parser DefButton
buttonP = (lexeme . choice . map try $
  map (uncurry statement) keywordButtons ++ 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     <$> some buttonP)
  , ("tap-hold"       , KTapHold     <$> lexeme numP <*> buttonP <*> buttonP)
  , ("tap-hold-next"
    , KTapHoldNext <$> lexeme numP <*> buttonP <*> buttonP
                   <*> optional (keywordP "timeout-button" buttonP))
  , ("tap-next-release"
    , KTapNextRelease <$> buttonP <*> buttonP)
  , ("tap-hold-next-release"
    , KTapHoldNextRelease <$> lexeme numP <*> buttonP <*> buttonP
                          <*> optional (keywordP "timeout-button" buttonP))
  , ("tap-next-press"
    , KTapNextPress <$> buttonP <*> buttonP)
  , ("tap-hold-next-press"
    , KTapHoldNextPress <$> lexeme numP <*> buttonP <*> buttonP
                        <*> optional (keywordP "timeout-button" buttonP))
  , ("tap-next"       , KTapNext     <$> buttonP     <*> buttonP)
  , ("layer-toggle"   , KLayerToggle <$> lexeme word)
  , ("momentary-layer" , KLayerToggle <$> lexeme word)
  , ("layer-switch"    , KLayerSwitch <$> lexeme word)
  , ("permanent-layer" , KLayerSwitch <$> lexeme word)
  , ("layer-add"      , KLayerAdd    <$> lexeme word)
  , ("layer-rem"      , KLayerRem    <$> lexeme word)
  , ("layer-delay"    , KLayerDelay  <$> lexeme numP <*> lexeme word)
  , ("layer-next"     , KLayerNext   <$> lexeme word)
  , ("around-next"    , KAroundNext  <$> buttonP)
  , ("around-next-single", KAroundNextSingle <$> buttonP)
  , ("before-after-next", KBeforeAfterNext <$> buttonP <*> buttonP)
  , ("around-next-timeout", KAroundNextTimeout <$> lexeme numP <*> buttonP <*> buttonP)
  , ("tap-macro"
    , KTapMacro <$> lexeme (some buttonP) <*> optional (keywordP "delay" numP))
  , ("tap-macro-release"
    , KTapMacroRelease <$> lexeme (some buttonP) <*> optional (keywordP "delay" numP))
  , ("cmd-button"     , KCommand     <$> lexeme textP <*> optional (lexeme textP))
  , ("pause"          , KPause . fromIntegral <$> lexeme numP)
  , ("sticky-key"     , KStickyKey   <$> lexeme numP <*> buttonP)
  ]
  ++ map (\(nm,_,btn) -> (nm, btn <$> buttonP <*> buttonP)) implArndButtons
 where
  timed :: Parser [(Int, DefButton)]
  timed = many ((,) <$> lexeme numP <*> lexeme buttonP)

implArndButtons :: [(Text, ImplArnd, DefButton -> DefButton -> DefButton)]
implArndButtons = sortBy (flip compare `on` (T.length . view _1)) -- Prevents early return due to `around`
  [ ("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
  , KRef  <$> derefP
  , lexeme $ fromNamed buttonNames
  , try moddedP
  , lexeme $ try rmTapMacroP
  , lexeme $ try pauseP
  , KEmit <$> keycodeP
  , KComposeSeq <$> composeSeqP
  ]

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

-- | Parse an input token
itokenP :: Parser IToken
itokenP = choice $ map (try . uncurry statement) itokens

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

-- | Parse an output token
otokenP :: Parser OToken
otokenP = choice $ map (try . uncurry statement) otokens

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

-- | Parse an impl arnd token
implArndP :: Parser ImplArnd
implArndP = lexeme . choice $
  try (IADisabled <$ symbol "disabled")
  : map (\(s, v, _) -> try $ v <$ symbol s) implArndButtons

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

-- | All possible configuration options that can be passed in the defcfg block
settingP :: Parser DefSetting
settingP = let f s p = symbol s *> p in
  (lexeme . choice . map try $
    [ SIToken      <$> f "input"         itokenP
    , SOToken      <$> f "output"        otokenP
    , SCmpSeq      <$> f "cmp-seq"       buttonP
    , SFallThrough <$> f "fallthrough"   bool
    , SAllowCmd    <$> f "allow-cmd"     bool
    , SCmpSeqDelay <$> f "cmp-seq-delay" numP
    , SKeySeqDelay <$> f "key-seq-delay" numP
    , SImplArnd    <$> f "implicit-around" implArndP
    ])

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

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

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

defsrcP :: Parser DefSrc
defsrcP =
  DefSrc
    <$> optional (keywordP "name" word)
    <*> many (lexeme keycodeP)

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

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

layerSettingP :: Parser DefLayerSetting
layerSettingP =
  lexeme . choice . map try $
    [ LSrcName <$> keywordP "source" word
    , LImplArnd <$> keywordP "implicit-around" implArndP
    , LButton <$> buttonP
    ]