Classes.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

{- |
Module      :  Neovim.Plugin.Classes
Description :  Classes and data types related to plugins
Copyright   :  (c) Sebastian Witte
License     :  Apache-2.0

Maintainer  :  woozletoff@gmail.com
Stability   :  experimental
Portability :  GHC
-}
module Neovim.Plugin.Classes (
    FunctionalityDescription (..),
    FunctionName (..),
    NeovimEventId (..),
    SubscriptionId (..),
    Subscription (..),
    NvimMethod (..),
    Synchronous (..),
    CommandOption (..),
    CommandOptions,
    RangeSpecification (..),
    CommandArguments (..),
    getCommandOptions,
    mkCommandOptions,
    AutocmdOptions (..),
    HasFunctionName (..),
) where

import Neovim.Classes

import Control.Monad.Error.Class (MonadError (throwError))
import Data.Char (isDigit)
import Data.Default (Default (..))
import Data.List (groupBy, sort)
import qualified Data.Map as Map
import Data.Maybe (catMaybes, mapMaybe)
import Data.MessagePack (Object (..))
import Data.String (IsString (..))
import Data.Text (Text)
import Prettyprinter (cat, comma, lparen, rparen, viaShow)

import Prelude hiding (sequence)

-- | Essentially just a string.
newtype FunctionName = F Text
    deriving (Eq, Ord, Show, Read, Generic)
    deriving (NFData, Pretty) via Text

newtype NeovimEventId = NeovimEventId Text
    deriving (Eq, Ord, Show, Read, Generic)
    deriving (Pretty) via Text
    deriving (NFData) via Text

instance NvimObject NeovimEventId where
    toObject (NeovimEventId e) = toObject e
    fromObject o = NeovimEventId <$> fromObject o

newtype SubscriptionId = SubscriptionId Int64
    deriving (Eq, Ord, Show, Read)
    deriving (Enum) via Int64

data Subscription = Subscription
    { subId :: SubscriptionId
    , subEventId :: NeovimEventId
    , subAction :: [Object] -> IO ()
    }

{- | Functionality specific functional description entries.

 All fields which are directly specified in these constructors are not
 optional, but can partialy be generated via the Template Haskell functions.
 The last field is a data type that contains all relevant options with
 sensible defaults, hence 'def' can be used as an argument.
-}
data FunctionalityDescription
    = -- | Exported function. Callable via @call name(arg1,arg2)@.
      --
      -- * Name of the function (must start with an uppercase letter)
      -- * Option to indicate how neovim should behave when calling this function
      Function FunctionName Synchronous
    | -- | Exported Command. Callable via @:Name arg1 arg2@.
      --
      -- * Name of the command (must start with an uppercase letter)
      -- * Options to configure neovim's behavior for calling the command
      Command FunctionName CommandOptions
    | -- | Exported autocommand. Will call the given function if the type and
      -- filter match.
      --
      -- NB: Since we are registering this on the Haskell side of things, the
      -- number of accepted arguments should be 0.
      --
      -- * Type of the autocmd (e.g. \"BufWritePost\")
      -- * Name for the function to call
      -- * Whether to use rpcrequest or rpcnotify
      -- * Options for the autocmd (use 'def' here if you don't want to change anything)
      Autocmd Text FunctionName Synchronous AutocmdOptions
    deriving (Show, Read, Eq, Ord, Generic)

instance NFData FunctionalityDescription

instance Pretty FunctionalityDescription where
    pretty = \case
        Function fname s ->
            "Function" <+> pretty s <+> pretty fname
        Command fname copts ->
            "Command" <+> pretty copts <+> pretty fname
        Autocmd t fname s aopts ->
            "Autocmd"
                <+> pretty t
                <+> pretty s
                <+> pretty aopts
                <+> pretty fname

{- | This option detemines how neovim should behave when calling some
 functionality on a remote host.
-}
data Synchronous
    = -- | Call the functionality entirely for its side effects and do not wait
      -- for it to finish. Calling a functionality with this flag set is
      -- completely asynchronous and nothing is really expected to happen. This
      -- is why a call like this is called notification on the neovim side of
      -- things.
      Async
    | -- | Call the function and wait for its result. This is only synchronous on
      -- the neovim side. This means that the GUI will (probably) not
      -- allow any user input until a reult is received.
      Sync
    deriving (Show, Read, Eq, Ord, Enum, Generic)

instance NFData Synchronous

instance Pretty Synchronous where
    pretty = \case
        Async -> "async"
        Sync -> "sync"

instance IsString Synchronous where
    fromString = \case
        "sync" -> Sync
        "async" -> Async
        _ -> error "Only \"sync\" and \"async\" are valid string representations"

instance NvimObject Synchronous where
    toObject = \case
        Async -> toObject False
        Sync -> toObject True

    fromObject = \case
        ObjectBool True -> return Sync
        ObjectBool False -> return Async
        ObjectInt 0 -> return Async
        _ -> return Sync

{- | Options for commands.

 Some command can also be described by using the OverloadedString extensions.
 This means that you can write a literal 'String' inside your source file in
 place for a 'CommandOption' value. See the documentation for each value on
 how these strings should look like (Both versions are compile time checked.)
-}
data CommandOption
    = -- | Stringliteral "sync" or "async"
      CmdSync Synchronous
    | -- | Register passed to the command.
      --
      -- Stringliteral: @\"\\\"\"@
      CmdRegister
    | -- | Command takes a specific amount of arguments
      --
      -- Automatically set via template haskell functions. You
      -- really shouldn't use this option yourself unless you have
      -- to.
      CmdNargs String
    | -- | Determines how neovim passes the range.
      --
      -- Stringliterals: \"%\" for 'WholeFile', \",\" for line
      --                 and \",123\" for 123 lines.
      CmdRange RangeSpecification
    | -- | Command handles a count. The argument defines the
      -- default count.
      --
      -- Stringliteral: string of numbers (e.g. "132")
      CmdCount Word
    | -- | Command handles a bang
      --
      -- Stringliteral: \"!\"
      CmdBang
    | -- | Verbatim string passed to the @-complete=@ command attribute
      CmdComplete String
    deriving (Eq, Ord, Show, Read, Generic)

instance NFData CommandOption

instance Pretty CommandOption where
    pretty = \case
        CmdSync s ->
            pretty s
        CmdRegister ->
            "\""
        CmdNargs n ->
            pretty n
        CmdRange rs ->
            pretty rs
        CmdCount c ->
            pretty c
        CmdBang ->
            "!"
        CmdComplete cs ->
            pretty cs

instance IsString CommandOption where
    fromString = \case
        "%" -> CmdRange WholeFile
        "\"" -> CmdRegister
        "!" -> CmdBang
        "sync" -> CmdSync Sync
        "async" -> CmdSync Async
        "," -> CmdRange CurrentLine
        ',' : ds | not (null ds) && all isDigit ds -> CmdRange (read ds)
        ds | not (null ds) && all isDigit ds -> CmdCount (read ds)
        _ -> error "Not a valid string for a CommandOptions. Check the docs!"

{- | Newtype wrapper for a list of 'CommandOption'. Any properly constructed
 object of this type is sorted and only contains zero or one object for each
 possible option.
-}
newtype CommandOptions = CommandOptions {getCommandOptions :: [CommandOption]}
    deriving (Eq, Ord, Show, Read, Generic)

instance NFData CommandOptions

instance Pretty CommandOptions where
    pretty (CommandOptions os) =
        cat $ map pretty os

{- | Smart constructor for 'CommandOptions'. This sorts the command options and
 removes duplicate entries for semantically the same thing. Note that the
 smallest option stays for whatever ordering is defined. It is best to simply
 not define the same thing multiple times.
-}
mkCommandOptions :: [CommandOption] -> CommandOptions
mkCommandOptions = CommandOptions . map head . groupBy constructor . sort
  where
    constructor a b = case (a, b) of
        _ | a == b -> True
        -- Only CmdSync and CmdNargs may fail for the equality check,
        -- so we just have to check those.
        (CmdSync _, CmdSync _) -> True
        (CmdRange _, CmdRange _) -> True
        -- Range and conut are mutually recursive.
        -- XXX Actually '-range=N' and '-count=N' are, but the code in
        --     remote#define#CommandOnChannel treats it exclusive as a whole.
        --     (see :h :command-range)
        (CmdRange _, CmdCount _) -> True
        (CmdNargs _, CmdNargs _) -> True
        _ -> False

instance NvimObject CommandOptions where
    toObject (CommandOptions opts) =
        (toObject :: Dictionary -> Object) . Map.fromList $ mapMaybe addOption opts
      where
        addOption = \case
            CmdRange r -> Just ("range", toObject r)
            CmdCount n -> Just ("count", toObject n)
            CmdBang -> Just ("bang", ObjectBinary "")
            CmdRegister -> Just ("register", ObjectBinary "")
            CmdNargs n -> Just ("nargs", toObject n)
            CmdComplete cs -> Just ("complete", toObject cs)
            _ -> Nothing

    fromObject o =
        throwError $
            "Did not expect to receive a CommandOptions object:" <+> viaShow o

-- | Specification of a range that acommand can operate on.
data RangeSpecification
    = -- | The line the cursor is at when the command is invoked.
      CurrentLine
    | -- | Let the command operate on every line of the file.
      WholeFile
    | -- | Let the command operate on each line in the given range.
      RangeCount Int
    deriving (Eq, Ord, Show, Read, Generic)

instance NFData RangeSpecification

instance Pretty RangeSpecification where
    pretty = \case
        CurrentLine ->
            mempty
        WholeFile ->
            "%"
        RangeCount c ->
            pretty c

instance NvimObject RangeSpecification where
    toObject = \case
        CurrentLine -> ObjectBinary ""
        WholeFile -> ObjectBinary "%"
        RangeCount n -> toObject n

    fromObject o =
        throwError $
            "Did not expect to receive a RangeSpecification object:" <+> viaShow o

{- | You can use this type as the first argument for a function which is
 intended to be exported as a command. It holds information about the special
 attributes a command can take.
-}
data CommandArguments = CommandArguments
    { bang :: Maybe Bool
    -- ^ 'Nothing' means that the function was not defined to handle a bang,
    -- otherwise it means that the bang was passed (@'Just' 'True'@) or that it
    -- was not passed when called (@'Just' 'False'@).
    , range :: Maybe (Int, Int)
    -- ^ Range passed from neovim. Only set if 'CmdRange' was used in the export
    -- declaration of the command.
    --
    -- Example:
    --
    -- * @Just (1,12)@
    , count :: Maybe Int
    -- ^ Count passed by neovim. Only set if 'CmdCount' was used in the export
    -- declaration of the command.
    , register :: Maybe String
    -- ^ Register that the command can\/should\/must use.
    }
    deriving (Eq, Ord, Show, Read, Generic)

instance NFData CommandArguments

instance Pretty CommandArguments where
    pretty CommandArguments{..} =
        cat $
            catMaybes
                [ (\b -> if b then "!" else mempty) <$> bang
                , ( \(s, e) ->
                        lparen <> pretty s <> comma
                            <+> pretty e <> rparen
                  )
                    <$> range
                , pretty <$> count
                , pretty <$> register
                ]

instance Default CommandArguments where
    def =
        CommandArguments
            { bang = Nothing
            , range = Nothing
            , count = Nothing
            , register = Nothing
            }

-- XXX This instance is used as a bit of a hack, so that I don't have to write
--     special code handling in the code generator and "Neovim.RPC.SocketReader".
instance NvimObject CommandArguments where
    toObject CommandArguments{..} =
        (toObject :: Dictionary -> Object)
            . Map.fromList
            . catMaybes
            $ [ bang >>= \b -> return ("bang", toObject b)
              , range >>= \r -> return ("range", toObject r)
              , count >>= \c -> return ("count", toObject c)
              , register >>= \r -> return ("register", toObject r)
              ]

    fromObject (ObjectMap m) = do
        let l key = mapM fromObject (Map.lookup (ObjectBinary key) m)
        bang <- l "bang"
        range <- l "range"
        count <- l "count"
        register <- l "register"
        return CommandArguments{..}
    fromObject ObjectNil = return def
    fromObject o =
        throwError $
            "Expected a map for CommandArguments object, but got: "
                <+> viaShow o

{- | Options that can be used to register an autocmd. See @:h :autocmd@ or any
 referenced neovim help-page from the fields of this data type.
-}
data AutocmdOptions = AutocmdOptions
    { acmdPattern :: String
    -- ^ Pattern to match on. (default: \"*\")
    , acmdNested :: Bool
    -- ^ Nested autocmd. (default: False)
    --
    -- See @:h autocmd-nested@
    , acmdGroup :: Maybe String
    -- ^ Group in which the autocmd should be registered.
    }
    deriving (Show, Read, Eq, Ord, Generic)

instance NFData AutocmdOptions

instance Pretty AutocmdOptions where
    pretty AutocmdOptions{..} =
        pretty acmdPattern
            <+> if acmdNested
                then "nested"
                else
                    "unnested"
                        <> maybe mempty (\g -> mempty <+> pretty g) acmdGroup

instance Default AutocmdOptions where
    def =
        AutocmdOptions
            { acmdPattern = "*"
            , acmdNested = False
            , acmdGroup = Nothing
            }

instance NvimObject AutocmdOptions where
    toObject AutocmdOptions{..} =
        (toObject :: Dictionary -> Object) . Map.fromList $
            [ ("pattern", toObject acmdPattern)
            , ("nested", toObject acmdNested)
            ]
                ++ catMaybes
                    [ acmdGroup >>= \g -> return ("group", toObject g)
                    ]
    fromObject o =
        throwError $
            "Did not expect to receive an AutocmdOptions object: " <+> viaShow o

newtype NvimMethod = NvimMethod {nvimMethodName :: Text}
    deriving (Eq, Ord, Show, Read, Generic)
    deriving (Pretty, NFData) via Text

-- | Conveniennce class to extract a name from some value.
class HasFunctionName a where
    name :: a -> FunctionName
    nvimMethod :: a -> NvimMethod

instance HasFunctionName FunctionalityDescription where
    name = \case
        Function n _ -> n
        Command n _ -> n
        Autocmd _ n _ _ -> n

    nvimMethod = \case
        Function (F n) _ -> NvimMethod $ n <> ":function"
        Command (F n) _ -> NvimMethod $ n <> ":command"
        Autocmd _ (F n) _ _ -> NvimMethod n