{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TemplateHaskell #-}

{- |
Module      :  Neovim.API.TH
Description :  Template Haskell API generation module
Copyright   :  (c) Sebastian Witte
License     :  Apache-2.0

Maintainer  :  woozletoff@gmail.com
Stability   :  experimental
-}
module Neovim.API.TH (
    generateAPI,
    function,
    function',
    command,
    command',
    autocmd,
    stringListTypeMap,
    textVectorTypeMap,
    bytestringVectorTypeMap,
    createFunction,
    module UnliftIO.Exception,
    module Neovim.Classes,
    module Data.Data,
    module Data.MessagePack,
) where

import Neovim.API.Parser
import Neovim.Classes
import Neovim.Context
import Neovim.Plugin.Classes (
    CommandArguments (..),
    CommandOption (..),
    FunctionName (..),
    FunctionalityDescription (..),
    mkCommandOptions,
 )
import Neovim.Plugin.Internal (ExportedFunctionality (..))
import Neovim.RPC.FunctionCall

import Language.Haskell.TH hiding (conP, dataD, instanceD)
import TemplateHaskell.Compat.V0208

import Control.Applicative
import Control.Arrow (first)
import Control.Concurrent.STM (STM)
import Control.Exception
import Control.Monad
import Data.ByteString (ByteString)
import Data.Char (isUpper, toUpper)
import Data.Data (Data, Typeable)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.MessagePack
import Data.Monoid
import qualified Data.Set as Set
import Data.Text (Text)
import Data.Vector (Vector)
import Prettyprinter (viaShow)
import UnliftIO.Exception

import Prelude
import qualified Data.Text as T

{- | Generate the API types and functions provided by @nvim --api-info@.

 The provided map allows the use of different Haskell types for the types
 defined in the API. The types must be an instance of 'NvimObject' and they
 must form an isomorphism with the sent messages types. Currently, it
 provides a Convenient way to replace the /String/ type with 'Text',
 'ByteString' or 'String'.
-}
generateAPI :: TypeMap -> Q [Dec]
generateAPI :: TypeMap -> Q [Dec]
generateAPI TypeMap
typeMap = do
    NeovimAPI
api <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. IO a -> Q a
runIO IO (Either (Doc AnsiStyle) NeovimAPI)
parseAPI
    let exceptionName :: Name
exceptionName = [Char] -> Name
mkName [Char]
"NeovimExceptionGen"
        exceptions :: [(Name, Int64)]
exceptions = (\([Char]
n, Int64
i) -> ([Char] -> Name
mkName ([Char]
"Neovim" forall a. Semigroup a => a -> a -> a
<> [Char]
n), Int64
i)) forall a b. (a -> b) -> [a] -> [b]
`map` NeovimAPI -> [([Char], Int64)]
errorTypes NeovimAPI
api
        customTypesN :: [(Name, Int64)]
customTypesN = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first [Char] -> Name
mkName forall a b. (a -> b) -> [a] -> [b]
`map` NeovimAPI -> [([Char], Int64)]
customTypes NeovimAPI
api
    forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
            [ forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> [Name] -> Q [Dec]
createDataTypeWithByteStringComponent Name
exceptionName (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Name, Int64)]
exceptions)
            , Name -> Q [Dec]
exceptionInstance Name
exceptionName
            , Name -> [(Name, Int64)] -> Q [Dec]
customTypeInstance Name
exceptionName [(Name, Int64)]
exceptions
            , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((\Name
n -> Name -> [Name] -> Q [Dec]
createDataTypeWithByteStringComponent Name
n [Name
n]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Name, Int64)]
customTypesN)
            , forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Name
n, Int64
i) -> Name -> [(Name, Int64)] -> Q [Dec]
customTypeInstance Name
n [(Name
n, Int64
i)]) [(Name, Int64)]
customTypesN
            , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TypeMap -> NeovimFunction -> Q [Dec]
createFunction TypeMap
typeMap) forall a b. (a -> b) -> a -> b
$ NeovimAPI -> [NeovimFunction]
functions NeovimAPI
api
            ]

-- | Maps type identifiers from the neovim API to Haskell types.
data TypeMap = TypeMap
    { TypeMap -> Map [Char] (Q Type)
typesOfAPI :: Map String (Q Type)
    , TypeMap -> Q Type
list :: Q Type
    }

stringListTypeMap :: TypeMap
stringListTypeMap :: TypeMap
stringListTypeMap =
    TypeMap
        { typesOfAPI :: Map [Char] (Q Type)
typesOfAPI =
            forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                [ ([Char]
"Boolean", [t|Bool|])
                , ([Char]
"Integer", [t|Int64|])
                , ([Char]
"LuaRef", [t|Int64|])
                , ([Char]
"Float", [t|Double|])
                , ([Char]
"String", [t|String|])
                , ([Char]
"Array", [t|[Object]|])
                , ([Char]
"Dictionary", [t|Map String Object|])
                , ([Char]
"void", [t|()|])
                ]
        , list :: Q Type
list = forall (m :: * -> *). Quote m => m Type
listT
        }

textVectorTypeMap :: TypeMap
textVectorTypeMap :: TypeMap
textVectorTypeMap =
    TypeMap
stringListTypeMap
        { typesOfAPI :: Map [Char] (Q Type)
typesOfAPI = Map [Char] (Q Type) -> Map [Char] (Q Type)
adjustTypeMapForText forall a b. (a -> b) -> a -> b
$ TypeMap -> Map [Char] (Q Type)
typesOfAPI TypeMap
stringListTypeMap
        , list :: Q Type
list = [t|Vector|]
        }
  where
    adjustTypeMapForText :: Map [Char] (Q Type) -> Map [Char] (Q Type)
adjustTypeMapForText =
        forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
"String" [t|Text|]
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
"Array" [t|Vector Object|]
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
"Dictionary" [t|Map Text Object|]

bytestringVectorTypeMap :: TypeMap
bytestringVectorTypeMap :: TypeMap
bytestringVectorTypeMap =
    TypeMap
textVectorTypeMap
        { typesOfAPI :: Map [Char] (Q Type)
typesOfAPI = Map [Char] (Q Type) -> Map [Char] (Q Type)
adjustTypeMapForByteString forall a b. (a -> b) -> a -> b
$ TypeMap -> Map [Char] (Q Type)
typesOfAPI TypeMap
textVectorTypeMap
        }
  where
    adjustTypeMapForByteString :: Map [Char] (Q Type) -> Map [Char] (Q Type)
adjustTypeMapForByteString =
        forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
"String" [t|ByteString|]
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
"Array" [t|Vector Object|]
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
"Dictionary" [t|Map ByteString Object|]

apiTypeToHaskellType :: TypeMap -> NeovimType -> Q Type
apiTypeToHaskellType :: TypeMap -> NeovimType -> Q Type
apiTypeToHaskellType typeMap :: TypeMap
typeMap@TypeMap{Map [Char] (Q Type)
typesOfAPI :: Map [Char] (Q Type)
typesOfAPI :: TypeMap -> Map [Char] (Q Type)
typesOfAPI, Q Type
list :: Q Type
list :: TypeMap -> Q Type
list} NeovimType
at = case NeovimType
at of
    NeovimType
Void -> [t|()|]
    NestedType NeovimType
t Maybe Int
Nothing ->
        forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT Q Type
list forall a b. (a -> b) -> a -> b
$ TypeMap -> NeovimType -> Q Type
apiTypeToHaskellType TypeMap
typeMap NeovimType
t
    NestedType NeovimType
t (Just Int
n) ->
        forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Int -> m Type
tupleT Int
n) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> a -> [a]
replicate Int
n forall a b. (a -> b) -> a -> b
$ TypeMap -> NeovimType -> Q Type
apiTypeToHaskellType TypeMap
typeMap NeovimType
t
    SimpleType [Char]
t ->
        forall a. a -> Maybe a -> a
fromMaybe ((forall (m :: * -> *). Quote m => Name -> m Type
conT forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Name
mkName) [Char]
t) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
t Map [Char] (Q Type)
typesOfAPI

{- | This function will create a wrapper function with neovim's function name
 as its name.

 Synchronous function:
 @
 buffer_get_number :: Buffer -> Neovim Int64
 buffer_get_number buffer = scall "buffer_get_number" [toObject buffer]
 @

 Asynchronous function:
 @
 vim_eval :: String -> Neovim (TMVar Object)
 vim_eval str = acall "vim_eval" [toObject str]
 @

 Asynchronous function without a return value:
 @
 vim_feed_keys :: String -> String -> Bool -> Neovim ()
 vim_feed_keys keys mode escape_csi =
     acallVoid "vim_feed_keys" [ toObject keys
                               , toObject mode
                               , toObject escape_csi
                               ]
 @
-}
createFunction :: TypeMap -> NeovimFunction -> Q [Dec]
createFunction :: TypeMap -> NeovimFunction -> Q [Dec]
createFunction TypeMap
typeMap NeovimFunction
nf = do
    let withDeferred :: Q Type -> Q Type
withDeferred
            | NeovimFunction -> Bool
async NeovimFunction
nf = forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT [t|STM|] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT [t|Either NeovimException|]
            | Bool
otherwise = forall a. a -> a
id

        callFn :: Q Exp
callFn
            | NeovimFunction -> Bool
async NeovimFunction
nf = [|acall|]
            | Bool
otherwise = [|scall'|]

        functionName :: Name
functionName = [Char] -> Name
mkName forall a b. (a -> b) -> a -> b
$ NeovimFunction -> [Char]
name NeovimFunction
nf
        toObjVar :: Name -> m Exp
toObjVar Name
v = [|toObject $(varE v)|]

    Type
retType <-
        let env :: Name
env = [Char] -> Name
mkName [Char]
"env"
         in forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m Cxt -> m Type -> m Type
forallT [Name -> TyVarBndr Specificity
specifiedPlainTV Name
env] (forall (m :: * -> *) a. Monad m => a -> m a
return [])
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT [t|Neovim $(varT env)|]
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Type -> Q Type
withDeferred
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeMap -> NeovimType -> Q Type
apiTypeToHaskellType TypeMap
typeMap
                forall a b. (a -> b) -> a -> b
$ NeovimFunction -> NeovimType
returnType NeovimFunction
nf

    -- prefix with arg0_, arg1_ etc. to prevent generated code from crashing due
    -- to keywords being used.
    -- see https://github.com/neovimhaskell/nvim-hs/issues/65
    let prefixWithNumber :: a -> [Char] -> [Char]
prefixWithNumber a
i [Char]
n = [Char]
"arg" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
i forall a. [a] -> [a] -> [a]
++ [Char]
"_" forall a. [a] -> [a] -> [a]
++ [Char]
n
        applyPrefixWithNumber :: NeovimFunction -> [(NeovimType, [Char])]
applyPrefixWithNumber =
            forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
                (\Int
i (NeovimType
t, [Char]
n) -> (NeovimType
t, forall {a}. Show a => a -> [Char] -> [Char]
prefixWithNumber Int
i [Char]
n))
                [Int
0 :: Int ..]
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. NeovimFunction -> [(NeovimType, [Char])]
parameters
    [(Type, Name)]
vars <-
        forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
            ( \(NeovimType
t, [Char]
n) ->
                (,)
                    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeMap -> NeovimType -> Q Type
apiTypeToHaskellType TypeMap
typeMap NeovimType
t
                    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
n
            )
            forall a b. (a -> b) -> a -> b
$ NeovimFunction -> [(NeovimType, [Char])]
applyPrefixWithNumber NeovimFunction
nf

    forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
        [ (forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
functionName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return) (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Type -> Type -> Type
AppT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT Type
ArrowT) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) Type
retType [(Type, Name)]
vars)
        , forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
            Name
functionName
            [ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                (forall a b. (a -> b) -> [a] -> [b]
map (forall (m :: * -> *). Quote m => Name -> m Pat
varP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Type, Name)]
vars)
                ( forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
                    ( Q Exp
callFn
                        forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ([|(F . T.pack)|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Lit
stringL forall b c a. (b -> c) -> (a -> b) -> a -> c
. NeovimFunction -> [Char]
name) NeovimFunction
nf)
                        forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE (forall a b. (a -> b) -> [a] -> [b]
map (forall {m :: * -> *}. Quote m => Name -> m Exp
toObjVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Type, Name)]
vars)
                    )
                )
                []
            ]
        ]

{- | @ createDataTypeWithObjectComponent SomeName [Foo,Bar]@
 will create this:
 @
 data SomeName = Foo !Object
               | Bar !Object
               deriving (Typeable, Eq, Show)
 @
-}
createDataTypeWithByteStringComponent :: Name -> [Name] -> Q [Dec]
createDataTypeWithByteStringComponent :: Name -> [Name] -> Q [Dec]
createDataTypeWithByteStringComponent Name
nme [Name]
cs = do
    Type
tObject <- [t|ByteString|]

    let strictNess :: (Bang, Type)
strictNess = (SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
SourceStrict, Type
tObject)

    forall (f :: * -> *) a. Applicative f => a -> f a
pure
        [ Cxt -> Name -> [UnitTyVarBndr] -> [Con] -> [Name] -> Dec
dataD
            []
            Name
nme
            []
            (forall a b. (a -> b) -> [a] -> [b]
map (\Name
n -> Name -> [(Bang, Type)] -> Con
NormalC Name
n [(Bang, Type)
strictNess]) [Name]
cs)
            ([Char] -> Name
mkName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Char]
"Typeable", [Char]
"Eq", [Char]
"Show", [Char]
"Generic"])
        , Cxt -> Type -> [Dec] -> Dec
instanceD [] (Type -> Type -> Type
AppT (Name -> Type
ConT ([Char] -> Name
mkName [Char]
"NFData")) (Name -> Type
ConT Name
nme)) []
        ]

{- | If the first parameter is @mkName NeovimException@, this function will
 generate  @instance Exception NeovimException@.
-}
exceptionInstance :: Name -> Q [Dec]
exceptionInstance :: Name -> Q [Dec]
exceptionInstance Name
exceptionName = do
    Type
tException <- [t|Exception|]
    forall (f :: * -> *) a. Applicative f => a -> f a
pure [Cxt -> Type -> [Dec] -> Dec
instanceD [] (Type
tException Type -> Type -> Type
`AppT` Name -> Type
ConT Name
exceptionName) []]

{- | @customTypeInstance Foo [(Bar, 1), (Quz, 2)]@
 will create this:
 @
 instance Serializable Foo where
     toObject (Bar bs) = ObjectExt 1 bs
     toObject (Quz bs) = ObjectExt 2 bs
     fromObject (ObjectExt 1 bs) = return $ Bar bs
     fromObject (ObjectExt 2 bs) = return $ Quz bs
     fromObject o = Left $ "Object is not convertible to: Foo Received: " <> show o
 @
-}
customTypeInstance :: Name -> [(Name, Int64)] -> Q [Dec]
customTypeInstance :: Name -> [(Name, Int64)] -> Q [Dec]
customTypeInstance Name
typeName [(Name, Int64)]
nis = do
    let fromObjectClause :: Name -> Int64 -> Q Clause
        fromObjectClause :: Name -> Int64 -> Q Clause
fromObjectClause Name
n Int64
i = do
            Name
bs <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"bs"
            let objectExtMatch :: Pat
objectExtMatch =
                    Name -> [Pat] -> Pat
conP
                        ([Char] -> Name
mkName [Char]
"ObjectExt")
                        [(Lit -> Pat
LitP forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
integerL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) Int64
i, Name -> Pat
VarP Name
bs]
            forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                [forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
objectExtMatch]
                (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|return $ $(conE n) $(varE bs)|])
                []
        fromObjectErrorClause :: Q Clause
        fromObjectErrorClause :: Q Clause
fromObjectErrorClause = do
            Name
o <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"o"
            let n :: [Char]
n = Name -> [Char]
nameBase Name
typeName
            forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
o]
                ( forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
                    [|
                        throwError $
                            pretty "Object is not convertible to:"
                                <+> viaShow n
                                <+> pretty "Received:"
                                <+> viaShow $(varE o)
                        |]
                )
                []

        toObjectClause :: Name -> Int64 -> Q Clause
        toObjectClause :: Name -> Int64 -> Q Clause
toObjectClause Name
n Int64
i = do
            Name
bs <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"bs"
            forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                [forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [Pat] -> Pat
conP Name
n [Name -> Pat
VarP Name
bs])]
                (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|ObjectExt $((litE . integerL . fromIntegral) i) $(varE bs)|])
                []

    Type
tNvimObject <- [t|NvimObject|]
    Dec
fToObject <- forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ([Char] -> Name
mkName [Char]
"toObject") forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> Int64 -> Q Clause
toObjectClause) [(Name, Int64)]
nis
    Dec
fFromObject <- forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ([Char] -> Name
mkName [Char]
"fromObject") forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> Int64 -> Q Clause
fromObjectClause) [(Name, Int64)]
nis forall a. Semigroup a => a -> a -> a
<> [Q Clause
fromObjectErrorClause]
    forall (f :: * -> *) a. Applicative f => a -> f a
pure [Cxt -> Type -> [Dec] -> Dec
instanceD [] (Type
tNvimObject Type -> Type -> Type
`AppT` Name -> Type
ConT Name
typeName) [Dec
fToObject, Dec
fFromObject]]

{- | Define an exported function by providing a custom name and referencing the
 function you want to export.

 Note that the name must start with an upper case letter.

 Example: @ $(function \"MyExportedFunction\" 'myDefinedFunction) 'Sync' @
-}
function :: String -> Name -> Q Exp
function :: [Char] -> Name -> Q Exp
function [] Name
_ = forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Empty names are not allowed for exported functions."
function customName :: [Char]
customName@(Char
c : [Char]
_) Name
functionName
    | (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isUpper) Char
c = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Custom function name must start with a capital letter: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [Char]
customName
    | Bool
otherwise = do
        ([ArgType]
_, Exp
fun) <- Name -> Q ([ArgType], Exp)
functionImplementation Name
functionName
        [|\funOpts -> EF (Function (F (T.pack $(litE (StringL customName)))) funOpts, $(return fun))|]

uppercaseFirstCharacter :: Name -> String
uppercaseFirstCharacter :: Name -> [Char]
uppercaseFirstCharacter Name
name = case Name -> [Char]
nameBase Name
name of
    [Char]
"" -> [Char]
""
    (Char
c : [Char]
cs) -> Char -> Char
toUpper Char
c forall a. a -> [a] -> [a]
: [Char]
cs

{- | Define an exported function. This function works exactly like 'function',
 but it generates the exported name automatically by converting the first
 letter to upper case.
-}
function' :: Name -> Q Exp
function' :: Name -> Q Exp
function' Name
functionName = [Char] -> Name -> Q Exp
function (Name -> [Char]
uppercaseFirstCharacter Name
functionName) Name
functionName

{- | Simply data type used to identify a string-ish type (e.g. 'String', 'Text',
 'ByteString' for a value of type.
-}
data ArgType
    = StringyType
    | ListOfStringyTypes
    | Optional ArgType
    | CommandArgumentsType
    | OtherType
    deriving (ArgType -> ArgType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ArgType -> ArgType -> Bool
$c/= :: ArgType -> ArgType -> Bool
== :: ArgType -> ArgType -> Bool
$c== :: ArgType -> ArgType -> Bool
Eq, Eq ArgType
ArgType -> ArgType -> Bool
ArgType -> ArgType -> Ordering
ArgType -> ArgType -> ArgType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ArgType -> ArgType -> ArgType
$cmin :: ArgType -> ArgType -> ArgType
max :: ArgType -> ArgType -> ArgType
$cmax :: ArgType -> ArgType -> ArgType
>= :: ArgType -> ArgType -> Bool
$c>= :: ArgType -> ArgType -> Bool
> :: ArgType -> ArgType -> Bool
$c> :: ArgType -> ArgType -> Bool
<= :: ArgType -> ArgType -> Bool
$c<= :: ArgType -> ArgType -> Bool
< :: ArgType -> ArgType -> Bool
$c< :: ArgType -> ArgType -> Bool
compare :: ArgType -> ArgType -> Ordering
$ccompare :: ArgType -> ArgType -> Ordering
Ord, Int -> ArgType -> [Char] -> [Char]
[ArgType] -> [Char] -> [Char]
ArgType -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [ArgType] -> [Char] -> [Char]
$cshowList :: [ArgType] -> [Char] -> [Char]
show :: ArgType -> [Char]
$cshow :: ArgType -> [Char]
showsPrec :: Int -> ArgType -> [Char] -> [Char]
$cshowsPrec :: Int -> ArgType -> [Char] -> [Char]
Show, ReadPrec [ArgType]
ReadPrec ArgType
Int -> ReadS ArgType
ReadS [ArgType]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ArgType]
$creadListPrec :: ReadPrec [ArgType]
readPrec :: ReadPrec ArgType
$creadPrec :: ReadPrec ArgType
readList :: ReadS [ArgType]
$creadList :: ReadS [ArgType]
readsPrec :: Int -> ReadS ArgType
$creadsPrec :: Int -> ReadS ArgType
Read)

{- | Given a value of type 'Type', test whether it can be classified according
 to the constructors of "ArgType".
-}
classifyArgType :: Type -> Q ArgType
classifyArgType :: Type -> Q ArgType
classifyArgType Type
t = do
    Set Name
set <- Q (Set Name)
genStringTypesSet
    Type
maybeType <- [t|Maybe|]
    Type
cmdArgsType <- [t|CommandArguments|]
    case Type
t of
        AppT Type
ListT (ConT Name
str)
            | Name
str forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
set ->
                forall (m :: * -> *) a. Monad m => a -> m a
return ArgType
ListOfStringyTypes
        AppT Type
m mt :: Type
mt@(ConT Name
_)
            | Type
m forall a. Eq a => a -> a -> Bool
== Type
maybeType ->
                ArgType -> ArgType
Optional forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q ArgType
classifyArgType Type
mt
        ConT Name
str
            | Name
str forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
set ->
                forall (m :: * -> *) a. Monad m => a -> m a
return ArgType
StringyType
        Type
cmd
            | Type
cmd forall a. Eq a => a -> a -> Bool
== Type
cmdArgsType ->
                forall (m :: * -> *) a. Monad m => a -> m a
return ArgType
CommandArgumentsType
        Type
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ArgType
OtherType
  where
    genStringTypesSet :: Q (Set Name)
genStringTypesSet = do
        Cxt
types <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [[t|String|], [t|ByteString|], [t|Text|]]
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [Name
n | ConT Name
n <- Cxt
types]

{- | Similarly to 'function', this function is used to export a command with a
 custom name.

 Note that commands must start with an upper case letter.

 Due to limitations on the side of (neo)vim, commands can only have one of the
 following five signatures, where you can replace 'String' with 'ByteString'
 or 'Text' if you wish:

 * 'CommandArguments' -> 'Neovim' env ()

 * 'CommandArguments' -> 'Maybe' 'String' -> 'Neovim' env ()

 * 'CommandArguments' -> 'String' -> 'Neovim' env ()

 * 'CommandArguments' -> ['String'] -> 'Neovim' env ()

 * 'CommandArguments' -> 'String' -> ['String'] -> 'Neovim' env ()

 Example: @ $(command \"RememberThePrime\" 'someFunction) ['CmdBang'] @

 Note that the list of command options (i.e. the last argument) removes
 duplicate options by means of some internally convenient sorting. You should
 simply not define the same option twice.
-}
command :: String -> Name -> Q Exp
command :: [Char] -> Name -> Q Exp
command [] Name
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"Empty names are not allowed for exported commands."
command customFunctionName :: [Char]
customFunctionName@(Char
c : [Char]
_) Name
functionName
    | (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isUpper) Char
c = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Custom command name must start with a capital letter: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [Char]
customFunctionName
    | Bool
otherwise = do
        ([ArgType]
argTypes, Exp
fun) <- Name -> Q ([ArgType], Exp)
functionImplementation Name
functionName
        -- See :help :command-nargs for what the result strings mean
        case [ArgType]
argTypes of
            (ArgType
CommandArgumentsType : [ArgType]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            [ArgType]
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"First argument for a function exported as a command must be CommandArguments!"
        let nargs :: Q Exp
nargs = case forall a. [a] -> [a]
tail [ArgType]
argTypes of
                [] -> [|CmdNargs "0"|]
                [ArgType
StringyType] -> [|CmdNargs "1"|]
                [Optional ArgType
StringyType] -> [|CmdNargs "?"|]
                [ArgType
ListOfStringyTypes] -> [|CmdNargs "*"|]
                [ArgType
StringyType, ArgType
ListOfStringyTypes] -> [|CmdNargs "+"|]
                [ArgType]
_ ->
                    forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$
                        [[Char]] -> [Char]
unlines
                            [ [Char]
"Trying to generate a command without compatible types."
                            , [Char]
"Due to a limitation burdened on us by vimL, we can only"
                            , [Char]
"use a limited amount type signatures for commands. See"
                            , [Char]
"the documentation for 'command' for a more thorough"
                            , [Char]
"explanation."
                            ]
        [|
            \copts ->
                EF
                    ( Command
                        (F (T.pack $(litE (StringL customFunctionName))))
                        (mkCommandOptions ($(nargs) : copts))
                    , $(return fun)
                    )
            |]

{- | Define an exported command. This function works exactly like 'command', but
 it generates the command name by converting the first letter to upper case.
-}
command' :: Name -> Q Exp
command' :: Name -> Q Exp
command' Name
functionName = [Char] -> Name -> Q Exp
command (Name -> [Char]
uppercaseFirstCharacter Name
functionName) Name
functionName

{- | This function generates an export for autocmd. Since this is a static
 registration, arguments are not allowed here. You can, of course, define a
 fully applied function and pass it as an argument. If you have to add
 autocmds dynamically, it can be done with 'addAutocmd'.

 Example:

 @
 someFunction :: a -> b -> c -> d -> Neovim r st res
 someFunction = ...

 theFunction :: Neovim r st res
 theFunction = someFunction 1 2 3 4
-}

{- $(autocmd 'theFunction) def
 @

 @def@ is of type 'AutocmdOptions'.

 Note that you have to define @theFunction@ in a different module due to
 the use of Template Haskell.
-}

autocmd :: Name -> Q Exp
autocmd :: Name -> Q Exp
autocmd Name
functionName =
    let ~(Char
c : [Char]
cs) = Name -> [Char]
nameBase Name
functionName
     in do
            ([ArgType]
as, Exp
fun) <- Name -> Q ([ArgType], Exp)
functionImplementation Name
functionName
            case [ArgType]
as of
                [] ->
                    [|\t sync acmdOpts -> EF (Autocmd t (F (T.pack $(litE (StringL (toUpper c : cs))))) sync acmdOpts, $(return fun))|]
                [ArgType]
_ ->
                    forall a. HasCallStack => [Char] -> a
error [Char]
"Autocmd functions have to be fully applied (i.e. they should not take any arguments)."

{- | Generate a function of type @[Object] -> Neovim' Object@ from the argument
 function.

 The function
 @
 add :: Int -> Int -> Int
 add = (+)
 @
 will be converted to
 @
 \args -> case args of
     [x,y] -> case pure add <*> fromObject x <*> fromObject y of
         Left e -> err $ "Wrong type of arguments for add: " ++ e
         Right action -> toObject <$> action
     _ -> err $ "Wrong number of arguments for add: " ++ show xs
 @
-}
functionImplementation :: Name -> Q ([ArgType], Exp)
functionImplementation :: Name -> Q ([ArgType], Exp)
functionImplementation Name
functionName = do
    Info
fInfo <- Name -> Q Info
reify Name
functionName
    [ArgType]
nargs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q ArgType
classifyArgType forall a b. (a -> b) -> a -> b
$ case Info
fInfo of
        VarI Name
_ Type
functionType Maybe Dec
_ ->
            Type -> Cxt
determineNumberOfArguments Type
functionType
        Info
x ->
            forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Value given to function is (likely) not the name of a function.\n" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Info
x

    Exp
e <- [ArgType] -> Q Exp
topLevelCase [ArgType]
nargs
    forall (m :: * -> *) a. Monad m => a -> m a
return ([ArgType]
nargs, Exp
e)
  where
    determineNumberOfArguments :: Type -> [Type]
    determineNumberOfArguments :: Type -> Cxt
determineNumberOfArguments Type
ft = case Type
ft of
        ForallT [TyVarBndr Specificity]
_ Cxt
_ Type
t -> Type -> Cxt
determineNumberOfArguments Type
t
        AppT (AppT Type
ArrowT Type
t) Type
r -> Type
t forall a. a -> [a] -> [a]
: Type -> Cxt
determineNumberOfArguments Type
r
        Type
_ -> []
    -- \args -> case args of ...
    topLevelCase :: [ArgType] -> Q Exp
    topLevelCase :: [ArgType] -> Q Exp
topLevelCase [ArgType]
ts = do
        let n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length [ArgType]
ts
            minLength :: Int
minLength = forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | Optional ArgType
_ <- forall a. [a] -> [a]
reverse [ArgType]
ts]
        Name
args <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"args"
        forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE
            [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
args]
            ( forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE
                (forall {m :: * -> *}. Quote m => Name -> m Exp
varE Name
args)
                (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Int -> Q Match
matchingCase [Int
n, Int
n forall a. Num a => a -> a -> a
- Int
1 ..] [Int
0 .. Int
minLength] forall a. [a] -> [a] -> [a]
++ [Q Match
errorCase])
            )

    -- _ -> err "Wrong number of arguments"
    errorCase :: Q Match
    errorCase :: Q Match
errorCase =
        forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
            forall (m :: * -> *). Quote m => m Pat
wildP
            ( forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
                [|
                    throw . ErrorMessage . pretty $
                        "Wrong number of arguments for function: "
                            ++ $(litE (StringL (nameBase functionName)))
                    |]
            )
            []

    -- [x,y] -> case pure add <*> fromObject x <*> fromObject y of ...
    matchingCase :: Int -> Int -> Q Match
    matchingCase :: Int -> Int -> Q Match
matchingCase Int
n Int
x = do
        [Maybe Name]
vars <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Int
_ -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x") [Int
1 .. Int
n]
        let optVars :: [Maybe Name]
optVars = forall a. Int -> a -> [a]
replicate Int
x (forall a. Maybe a
Nothing :: Maybe Name)
        forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
            ((forall (m :: * -> *). Quote m => [m Pat] -> m Pat
listP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes) [Maybe Name]
vars)
            ( forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
                ( forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE
                    ( forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
                        Q Exp -> (Maybe Name, Q Exp) -> Q Exp
genArgumentCast
                        [|pure $(varE functionName)|]
                        (forall a b. [a] -> [b] -> [(a, b)]
zip ([Maybe Name]
vars forall a. [a] -> [a] -> [a]
++ [Maybe Name]
optVars) (forall a. a -> [a]
repeat [|(<*>)|]))
                    )
                    [Q Match
successfulEvaluation, Q Match
failedEvaluation]
                )
            )
            []

    genArgumentCast :: Q Exp -> (Maybe Name, Q Exp) -> Q Exp
    genArgumentCast :: Q Exp -> (Maybe Name, Q Exp) -> Q Exp
genArgumentCast Q Exp
e = \case
        (Just Name
v, Q Exp
op) ->
            forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE (forall a. a -> Maybe a
Just Q Exp
e) Q Exp
op (forall a. a -> Maybe a
Just [|fromObject $(varE v)|])
        (Maybe Name
Nothing, Q Exp
op) ->
            forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE (forall a. a -> Maybe a
Just Q Exp
e) Q Exp
op (forall a. a -> Maybe a
Just [|pure Nothing|])

    successfulEvaluation :: Q Match
    successfulEvaluation :: Q Match
successfulEvaluation =
        forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"action" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Name
action ->
            forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
                (forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [Pat] -> Pat
conP ([Char] -> Name
mkName [Char]
"Right") [Name -> Pat
VarP Name
action]))
                (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|toObject <$> $(varE action)|])
                []
    failedEvaluation :: Q Match
    failedEvaluation :: Q Match
failedEvaluation =
        forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"e" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Name
e ->
            forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
                (forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [Pat] -> Pat
conP ([Char] -> Name
mkName [Char]
"Left") [Name -> Pat
VarP Name
e]))
                (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|err ($(varE e) :: Doc AnsiStyle)|])
                []