Help.hs

{-# LANGUAGE TransformListComp, OverloadedStrings #-}

{-|
Module      : Client.Commands.Help
Description : Implementation of the /help command
Copyright   : (c) Eric Mertens, 2016
License     : ISC
Maintainer  : emertens@gmail.com

Implements the /help command, which is responsible for managing the help buffer.
Unfortunately, this makes this command somewhat unique in that it's responsible for rendering.
-}

module Client.Commands.Help ( cmdHelp ) where

import           Client.Commands.Arguments.Renderer
import           Client.Commands.Arguments.Spec
import           Client.Commands.Interpolation
import           Client.Commands.Recognizer
import           Client.Commands.Types
import           Client.Configuration (configMacros)
import           Client.Image.MircFormatting
import           Client.Image.PackedImage
import           Client.Image.Palette
import           Client.Image.Message
import           Client.State
import           Client.State.Focus (focusNetwork, Subfocus(FocusHelp))
import           Client.State.Help
import           Client.State.Network (sendMsg)
import           Control.Lens
import           Data.Foldable (toList)
import           Data.List (delete, intercalate, sortOn)
import           Data.List.NonEmpty (NonEmpty((:|)))
import           Data.Text (Text)
import qualified Data.Text as Text
import           Graphics.Vty.Attributes
import           Irc.Commands (ircHelp)

displayHelp :: ClientState -> HelpState -> IO CommandResult
displayHelp st help = commandSuccess . changeSubfocus FocusHelp $ set clientHelp help st

-- | Implementation of @/help@ command.
cmdHelp :: [CommandSection] -> Recognizer Command -> WindowCommand (Maybe String)
cmdHelp commandsList commands focus st (Just (':':queryStr)) =
  case focusNetwork focus of
    Nothing -> commandFailureMsg "empty network prefix requires focused network" st
    Just net -> cmdHelp commandsList commands focus st (Just (Text.unpack net ++ ':' : queryStr))
                -- Network name better not start with a colon! ;)
cmdHelp _ commands _ st (Just queryStr)
  | Just queryText == savedQueryText = commandSuccess (changeSubfocus FocusHelp st)
  | otherwise = loadHelp commands queryText st
  where
    savedQueryText = views (clientHelp . hsQuery) helpQueryToText st
    queryText = Text.pack queryStr
cmdHelp commandsList _ _ st Nothing = loadHelpList commandsList st

loadHelpList :: [CommandSection] -> ClientState -> IO CommandResult
loadHelpList commandList st = displayHelp st $ makeHelp Nothing $ listAllCommands commandList st

loadHelp :: Recognizer Command -> Text -> ClientState -> IO CommandResult
loadHelp commands query st =
  case Text.break (':' ==) query of
    (cmdName, "") -> loadHelpCmd commands cmdName st
    (net, topic) -> sendHelpQuery net (Text.tail topic) st

sendHelpQuery :: Text -> Text -> ClientState -> IO CommandResult
sendHelpQuery net topic st =
  case preview (clientConnection net) st of
    Just cs -> do
      sendMsg cs (ircHelp topic)
      displayHelp st (awaitHelp net topic)
    Nothing -> commandFailureMsg ("not connected to " <> net) st

loadHelpCmd :: Recognizer Command -> Text -> ClientState -> IO CommandResult
loadHelpCmd commands cmdName st =
  case views (clientConfig . configMacros) (recognize cmdName) st of
    Exact macro -> displayHelp st $ makeHelp (Just cmdName) $ macroHelpLines st cmdName macro
    Invalid -> commandCase []
    Prefix sfxs -> commandCase sfxs
  where
    commandCase macroSfxs =
      case recognize cmdName commands of
        Invalid -> failureCase macroSfxs
        Prefix sfxs -> failureCase (macroSfxs <> sfxs)
        Exact cmd -> displayHelp st $ makeHelp (Just cmdName) $ commandHelpLines st cmdName cmd

    failureCase sfxs
      | null sfxs = commandFailureMsg "unknown command, try /help with no argument" st
      | otherwise = commandFailureMsg ("unknown command, did you mean: " <> suggestions) st
        where suggestions = Text.intercalate " " ((cmdName <>) <$> sfxs)

-- | Generate detailed help for macro expansions
macroHelpLines ::
  ClientState {- ^ client state -} ->
  Text        {- ^ name         -} ->
  Macro       {- ^ macro        -} ->
  [Image']    {- ^ lines        -}
macroHelpLines
  st
  name
  Macro{ macroSpec = MacroSpec spec, macroCommands = commands }
  = reverse
      $ heading "Syntax: " <> commandSummary (makeArgsContext st) pal (pure name) spec
      : emptyLine
      : heading "Macro Expansion:"
      : map (\x -> "    " <> foldMap explainExpansion x) commands
  where
    pal = clientPalette st
    attr = withForeColor defAttr cyan
    explainExpansion chunk =
      case chunk of
        LiteralChunk txt -> text' defAttr (cleanText txt)
        VariableChunk var -> text' attr ("${" <> cleanText var <> "}")
        IntegerChunk i -> string attr ("${" <> show i <> "}")
        DefaultChunk c txt ->
          text' attr "${" <>
          explainExpansion c <>
          text' attr "|" <>
          text' defAttr (cleanText txt) <>
          text' attr "}"

-- | Generate detailed help lines for the command with the given name.
commandHelpLines ::
  ClientState {- ^ client state -} ->
  Text        {- ^ command name -} ->
  Command     {- ^ command      -} ->
  [Image']    {- ^ lines        -}
commandHelpLines
  st
  cmdName
  Command{cmdNames = names, cmdImplementation = impl, cmdArgumentSpec = spec, cmdDocumentation = doc}
  = reverse $ heading "Syntax: " <> commandSummary (makeArgsContext st) pal (pure cmdName) spec
      : emptyLine
      : aliasLines
     ++ explainContext impl
      : emptyLine
      : map (parseIrcText pal) (Text.lines doc)
  where
    pal = clientPalette st
    aliasLines =
      case delete cmdName (toList names) of
        [] -> []
        ns -> [ heading "Aliases: " <> text' defAttr (Text.intercalate ", " ns), emptyLine ]

heading :: Text -> Image'
heading = text' (withStyle defAttr bold)

-- | Generate an explanation of the context where the given command
-- implementation will be valid.
explainContext ::
  CommandImpl a {- ^ command implementation -} ->
  Image'        {- ^ help line              -}
explainContext impl =
  heading "Context: " <>
  case impl of
    ClientCommand {}   -> "client (works everywhere)"
    WindowCommand {}   -> "window (works on the current window)"
    NetworkCommand{}   -> "network (works when focused on active network)"
    MaybeChatCommand{} -> "network (works when focused on active network)" -- Intentional duplicate.
    ChatCommand{}      -> "chat (works when focused on an active channel or private message)"
    ChannelCommand{}   -> "channel (works when focused on active channel)"

-- | Generate the lines for the help window showing all commands.
listAllCommands ::
  [CommandSection] {- ^  commands  -} ->
  ClientState {- ^ client state    -} ->
  [Image']    {- ^ help lines      -}
listAllCommands commandsList st
  = intercalate [emptyLine]
  $ map reverse
  $ (listCommandSection st pal <$> commandsList)
 ++ [macroCommandSection st pal]
 where pal = clientPalette st

macroCommandSection ::
  ClientState    {- ^ client state    -} ->
  Palette        {- ^ palette         -} ->
  [Image']       {- ^ help lines      -}
macroCommandSection st pal
  | null macros = []
  | otherwise =
      text' (withStyle defAttr bold) "Macros" :
      [ commandSummary st pal (pure name) spec
      | Macro name (MacroSpec spec) _ <- macros
      , then sortOn by name
      ]
  where
    macros = toListOf (clientConfig . configMacros . folded) st

listCommandSection ::
  ClientState    {- ^ client state    -} ->
  Palette        {- ^ palette         -} ->
  CommandSection {- ^ command section -} ->
  [Image']       {- ^ help lines      -}
listCommandSection st pal sec
  = text' (withStyle defAttr bold) (cmdSectionName sec)
  : [ commandSummary (makeArgsContext st) pal names spec
    | -- pattern needed due to existential quantification
      Command { cmdNames        = names
              , cmdArgumentSpec = spec
              } <- cmdSectionCmds sec
    ]

-- | Generate the help line for the given command and its
-- specification for use in the list of commands.
commandSummary ::
  r                {- ^ client state             -} ->
  Palette          {- ^ palette                  -} ->
  NonEmpty Text    {- ^ command name and aliases -} ->
  Args r a         {- ^ argument specification   -} ->
  Image'           {- ^ summary help line        -}
commandSummary st pal (cmd :| _) args  =
  char defAttr '/' <>
  text' (view palCommandReady pal) cmd <>
  render pal' st True args ""

  where
    pal' = set palCommandPlaceholder defAttr pal

-- Empty line used as a separator
emptyLine :: Image'
emptyLine = char defAttr ' '