{-# LANGUAGE LambdaCase #-}
{-# 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.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 qualified Data.Text as T
import Data.Vector (Vector)
import Prettyprinter (viaShow)
import UnliftIO (STM)
import UnliftIO.Exception

import Prelude

{- | 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 <- (Doc AnsiStyle -> Q NeovimAPI)
-> (NeovimAPI -> Q NeovimAPI)
-> Either (Doc AnsiStyle) NeovimAPI
-> Q NeovimAPI
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> Q NeovimAPI
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q NeovimAPI)
-> (Doc AnsiStyle -> [Char]) -> Doc AnsiStyle -> Q NeovimAPI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc AnsiStyle -> [Char]
forall a. Show a => a -> [Char]
show) NeovimAPI -> Q NeovimAPI
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Doc AnsiStyle) NeovimAPI -> Q NeovimAPI)
-> Q (Either (Doc AnsiStyle) NeovimAPI) -> Q NeovimAPI
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either (Doc AnsiStyle) NeovimAPI)
-> Q (Either (Doc AnsiStyle) NeovimAPI)
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" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
n), Int64
i)) (([Char], Int64) -> (Name, Int64))
-> [([Char], Int64)] -> [(Name, Int64)]
forall a b. (a -> b) -> [a] -> [b]
`map` NeovimAPI -> [([Char], Int64)]
errorTypes NeovimAPI
api
        customTypesN :: [(Name, Int64)]
customTypesN = ([Char] -> Name) -> ([Char], Int64) -> (Name, Int64)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first [Char] -> Name
mkName (([Char], Int64) -> (Name, Int64))
-> [([Char], Int64)] -> [(Name, Int64)]
forall a b. (a -> b) -> [a] -> [b]
`map` NeovimAPI -> [([Char], Int64)]
customTypes NeovimAPI
api
    [[Dec]] -> [Dec]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
        ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q [Dec]] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
            [ [[Dec]] -> [Dec]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[Dec]] -> [Dec]) -> ([Dec] -> [[Dec]]) -> [Dec] -> [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Dec] -> [[Dec]]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> [Name] -> Q [Dec]
createDataTypeWithByteStringComponent Name
exceptionName (((Name, Int64) -> Name) -> [(Name, Int64)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Int64) -> Name
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
            , ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (((Name, Int64) -> Q [Dec]) -> [(Name, Int64)] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((\Name
n -> Name -> [Name] -> Q [Dec]
createDataTypeWithByteStringComponent Name
n [Name
n]) (Name -> Q [Dec])
-> ((Name, Int64) -> Name) -> (Name, Int64) -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Int64) -> Name
forall a b. (a, b) -> a
fst) [(Name, Int64)]
customTypesN)
            , [[Dec]] -> [Dec]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Name, Int64) -> Q [Dec]) -> [(Name, Int64)] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(Name
n, Int64
i) -> Name -> [(Name, Int64)] -> Q [Dec]
customTypeInstance Name
n [(Name
n, Int64
i)]) [(Name, Int64)]
customTypesN
            , ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Q [[Dec]] -> Q [Dec])
-> ([NeovimFunction] -> Q [[Dec]]) -> [NeovimFunction] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NeovimFunction -> Q [Dec]) -> [NeovimFunction] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TypeMap -> NeovimFunction -> Q [Dec]
createFunction TypeMap
typeMap) ([NeovimFunction] -> Q [Dec]) -> [NeovimFunction] -> Q [Dec]
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 =
            [([Char], Q Type)] -> Map [Char] (Q Type)
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]
"Dict", [t|Map String Object|])
                , ([Char]
"Dictionary", [t|Map String Object|])
                , ([Char]
"void", [t|()|])
                ]
        , list :: Q Type
list = Q Type
forall (m :: * -> *). Quote m => m Type
listT
        }

textVectorTypeMap :: TypeMap
textVectorTypeMap :: TypeMap
textVectorTypeMap =
    TypeMap
stringListTypeMap
        { typesOfAPI = adjustTypeMapForText $ typesOfAPI stringListTypeMap
        , list = [t|Vector|]
        }
  where
    adjustTypeMapForText :: Map [Char] (Q Type) -> Map [Char] (Q Type)
adjustTypeMapForText =
        [Char] -> Q Type -> Map [Char] (Q Type) -> Map [Char] (Q Type)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
"String" [t|Text|]
            (Map [Char] (Q Type) -> Map [Char] (Q Type))
-> (Map [Char] (Q Type) -> Map [Char] (Q Type))
-> Map [Char] (Q Type)
-> Map [Char] (Q Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Q Type -> Map [Char] (Q Type) -> Map [Char] (Q Type)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
"Array" [t|Vector Object|]
            (Map [Char] (Q Type) -> Map [Char] (Q Type))
-> (Map [Char] (Q Type) -> Map [Char] (Q Type))
-> Map [Char] (Q Type)
-> Map [Char] (Q Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Q Type -> Map [Char] (Q Type) -> Map [Char] (Q Type)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
"Dict" [t|Map Text Object|]
            (Map [Char] (Q Type) -> Map [Char] (Q Type))
-> (Map [Char] (Q Type) -> Map [Char] (Q Type))
-> Map [Char] (Q Type)
-> Map [Char] (Q Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Q Type -> Map [Char] (Q Type) -> Map [Char] (Q Type)
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 = adjustTypeMapForByteString $ typesOfAPI textVectorTypeMap
        }
  where
    adjustTypeMapForByteString :: Map [Char] (Q Type) -> Map [Char] (Q Type)
adjustTypeMapForByteString =
        [Char] -> Q Type -> Map [Char] (Q Type) -> Map [Char] (Q Type)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
"String" [t|ByteString|]
            (Map [Char] (Q Type) -> Map [Char] (Q Type))
-> (Map [Char] (Q Type) -> Map [Char] (Q Type))
-> Map [Char] (Q Type)
-> Map [Char] (Q Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Q Type -> Map [Char] (Q Type) -> Map [Char] (Q Type)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
"Array" [t|Vector Object|]
            (Map [Char] (Q Type) -> Map [Char] (Q Type))
-> (Map [Char] (Q Type) -> Map [Char] (Q Type))
-> Map [Char] (Q Type)
-> Map [Char] (Q Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Q Type -> Map [Char] (Q Type) -> Map [Char] (Q Type)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
"Dict" [t|Map ByteString Object|]
            (Map [Char] (Q Type) -> Map [Char] (Q Type))
-> (Map [Char] (Q Type) -> Map [Char] (Q Type))
-> Map [Char] (Q Type)
-> Map [Char] (Q Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Q Type -> Map [Char] (Q Type) -> Map [Char] (Q Type)
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 :: TypeMap -> Map [Char] (Q Type)
typesOfAPI :: Map [Char] (Q Type)
typesOfAPI, Q Type
list :: TypeMap -> Q Type
list :: Q Type
list} NeovimType
at = case NeovimType
at of
    NeovimType
Void -> [t|()|]
    NestedType NeovimType
t Maybe Int
Nothing ->
        Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT Q Type
list (Q Type -> Q Type) -> Q Type -> Q Type
forall a b. (a -> b) -> a -> b
$ TypeMap -> NeovimType -> Q Type
apiTypeToHaskellType TypeMap
typeMap NeovimType
t
    NestedType NeovimType
t (Just Int
n) ->
        (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Int -> Q Type
forall (m :: * -> *). Quote m => Int -> m Type
tupleT Int
n) ([Q Type] -> Q Type) -> (Q Type -> [Q Type]) -> Q Type -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Q Type -> [Q Type]
forall a. Int -> a -> [a]
replicate Int
n (Q Type -> Q Type) -> Q Type -> Q Type
forall a b. (a -> b) -> a -> b
$ TypeMap -> NeovimType -> Q Type
apiTypeToHaskellType TypeMap
typeMap NeovimType
t
    SimpleType [Char]
t ->
        Q Type -> Maybe (Q Type) -> Q Type
forall a. a -> Maybe a -> a
fromMaybe ((Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> ([Char] -> Name) -> [Char] -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Name
mkName) [Char]
t) (Maybe (Q Type) -> Q Type) -> Maybe (Q Type) -> Q Type
forall a b. (a -> b) -> a -> b
$ [Char] -> Map [Char] (Q Type) -> Maybe (Q Type)
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 = Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT [t|STM|] (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT [t|Either NeovimException|]
            | Bool
otherwise = Q Type -> Q Type
forall a. a -> a
id

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

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

    let env :: Name
env = [Char] -> Name
mkName [Char]
"env"
    Type
retType <- Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT [t|Neovim $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
env)|]
                (Q Type -> Q Type)
-> (NeovimType -> Q Type) -> NeovimType -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Type -> Q Type
withDeferred
                (Q Type -> Q Type)
-> (NeovimType -> Q Type) -> NeovimType -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeMap -> NeovimType -> Q Type
apiTypeToHaskellType TypeMap
typeMap
                (NeovimType -> Q Type) -> NeovimType -> Q Type
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" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
i [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
n
        applyPrefixWithNumber :: NeovimFunction -> [(NeovimType, [Char])]
applyPrefixWithNumber =
            (Int -> (NeovimType, [Char]) -> (NeovimType, [Char]))
-> [Int] -> [(NeovimType, [Char])] -> [(NeovimType, [Char])]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
                (\Int
i (NeovimType
t, [Char]
n) -> (NeovimType
t, Int -> [Char] -> [Char]
forall {a}. Show a => a -> [Char] -> [Char]
prefixWithNumber Int
i [Char]
n))
                [Int
0 :: Int ..]
                ([(NeovimType, [Char])] -> [(NeovimType, [Char])])
-> (NeovimFunction -> [(NeovimType, [Char])])
-> NeovimFunction
-> [(NeovimType, [Char])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NeovimFunction -> [(NeovimType, [Char])]
parameters
    [(Type, Name)]
vars <-
        ((NeovimType, [Char]) -> Q (Type, Name))
-> [(NeovimType, [Char])] -> Q [(Type, Name)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM
            ( \(NeovimType
t, [Char]
n) ->
                (,)
                    (Type -> Name -> (Type, Name))
-> Q Type -> Q (Name -> (Type, Name))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeMap -> NeovimType -> Q Type
apiTypeToHaskellType TypeMap
typeMap NeovimType
t
                    Q (Name -> (Type, Name)) -> Q Name -> Q (Type, Name)
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
n
            )
            ([(NeovimType, [Char])] -> Q [(Type, Name)])
-> [(NeovimType, [Char])] -> Q [(Type, Name)]
forall a b. (a -> b) -> a -> b
$ NeovimFunction -> [(NeovimType, [Char])]
applyPrefixWithNumber NeovimFunction
nf

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

    [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        [ Cxt -> Name -> [UnitTyVarBndr] -> [Con] -> [Name] -> Dec
dataD
            []
            Name
nme
            []
            ((Name -> Con) -> [Name] -> [Con]
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 ([Char] -> Name) -> [[Char]] -> [Name]
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|]
    [Dec] -> Q [Dec]
forall a. a -> Q a
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 <- [Char] -> Q Name
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 (Lit -> Pat) -> (Int64 -> Lit) -> Int64 -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
integerL (Integer -> Lit) -> (Int64 -> Integer) -> Int64 -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral) Int64
i, Name -> Pat
VarP Name
bs]
            [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                [Pat -> Q Pat
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
objectExtMatch]
                (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|return $ $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
n) $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
bs)|])
                []
        fromObjectErrorClause :: Q Clause
        fromObjectErrorClause :: Q Clause
fromObjectErrorClause = do
            Name
o <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"o"
            let n :: [Char]
n = Name -> [Char]
nameBase Name
typeName
            [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
o]
                ( Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
                    [|
                        throwError $
                            pretty "Object is not convertible to:"
                                <+> viaShow n
                                <+> pretty "Received:"
                                <+> viaShow $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
o)
                        |]
                )
                []

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

    Type
tNvimObject <- [t|NvimObject|]
    Dec
fToObject <- Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ([Char] -> Name
mkName [Char]
"toObject") ([Q Clause] -> Q Dec) -> [Q Clause] -> Q Dec
forall a b. (a -> b) -> a -> b
$ ((Name, Int64) -> Q Clause) -> [(Name, Int64)] -> [Q Clause]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> Int64 -> Q Clause) -> (Name, Int64) -> Q Clause
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> Int64 -> Q Clause
toObjectClause) [(Name, Int64)]
nis
    Dec
fFromObject <- Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ([Char] -> Name
mkName [Char]
"fromObject") ([Q Clause] -> Q Dec) -> [Q Clause] -> Q Dec
forall a b. (a -> b) -> a -> b
$ ((Name, Int64) -> Q Clause) -> [(Name, Int64)] -> [Q Clause]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> Int64 -> Q Clause) -> (Name, Int64) -> Q Clause
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> Int64 -> Q Clause
fromObjectClause) [(Name, Int64)]
nis [Q Clause] -> [Q Clause] -> [Q Clause]
forall a. Semigroup a => a -> a -> a
<> [Q Clause
fromObjectErrorClause]
    [Dec] -> Q [Dec]
forall a. a -> Q a
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
_ = [Char] -> Q Exp
forall a. [Char] -> Q a
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 (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isUpper) Char
c = [Char] -> Q Exp
forall a. HasCallStack => [Char] -> a
error ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char]
"Custom function name must start with a capital letter: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
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 $(Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE ([Char] -> Lit
StringL [Char]
customName)))) funOpts, $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
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 Char -> [Char] -> [Char]
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
(ArgType -> ArgType -> Bool)
-> (ArgType -> ArgType -> Bool) -> Eq ArgType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ArgType -> ArgType -> Bool
== :: ArgType -> ArgType -> Bool
$c/= :: ArgType -> ArgType -> Bool
/= :: ArgType -> ArgType -> Bool
Eq, Eq ArgType
Eq ArgType =>
(ArgType -> ArgType -> Ordering)
-> (ArgType -> ArgType -> Bool)
-> (ArgType -> ArgType -> Bool)
-> (ArgType -> ArgType -> Bool)
-> (ArgType -> ArgType -> Bool)
-> (ArgType -> ArgType -> ArgType)
-> (ArgType -> ArgType -> ArgType)
-> Ord 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
$ccompare :: ArgType -> ArgType -> Ordering
compare :: ArgType -> ArgType -> Ordering
$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
>= :: ArgType -> ArgType -> Bool
$cmax :: ArgType -> ArgType -> ArgType
max :: ArgType -> ArgType -> ArgType
$cmin :: ArgType -> ArgType -> ArgType
min :: ArgType -> ArgType -> ArgType
Ord, Int -> ArgType -> [Char] -> [Char]
[ArgType] -> [Char] -> [Char]
ArgType -> [Char]
(Int -> ArgType -> [Char] -> [Char])
-> (ArgType -> [Char])
-> ([ArgType] -> [Char] -> [Char])
-> Show ArgType
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> ArgType -> [Char] -> [Char]
showsPrec :: Int -> ArgType -> [Char] -> [Char]
$cshow :: ArgType -> [Char]
show :: ArgType -> [Char]
$cshowList :: [ArgType] -> [Char] -> [Char]
showList :: [ArgType] -> [Char] -> [Char]
Show, ReadPrec [ArgType]
ReadPrec ArgType
Int -> ReadS ArgType
ReadS [ArgType]
(Int -> ReadS ArgType)
-> ReadS [ArgType]
-> ReadPrec ArgType
-> ReadPrec [ArgType]
-> Read ArgType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS ArgType
readsPrec :: Int -> ReadS ArgType
$creadList :: ReadS [ArgType]
readList :: ReadS [ArgType]
$creadPrec :: ReadPrec ArgType
readPrec :: ReadPrec ArgType
$creadListPrec :: ReadPrec [ArgType]
readListPrec :: ReadPrec [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 Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
set ->
                ArgType -> Q ArgType
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ArgType
ListOfStringyTypes
        AppT Type
m mt :: Type
mt@(ConT Name
_)
            | Type
m Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
maybeType ->
                ArgType -> ArgType
Optional (ArgType -> ArgType) -> Q ArgType -> Q ArgType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q ArgType
classifyArgType Type
mt
        ConT Name
str
            | Name
str Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
set ->
                ArgType -> Q ArgType
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ArgType
StringyType
        Type
cmd
            | Type
cmd Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
cmdArgsType ->
                ArgType -> Q ArgType
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ArgType
CommandArgumentsType
        Type
_ -> ArgType -> Q ArgType
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ArgType
OtherType
  where
    genStringTypesSet :: Q (Set Name)
genStringTypesSet = do
        Cxt
types <- [Q Type] -> Q Cxt
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [[t|String|], [t|ByteString|], [t|Text|]]
        Set Name -> Q (Set Name)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Set Name -> Q (Set Name)) -> Set Name -> Q (Set Name)
forall a b. (a -> b) -> a -> b
$ [Name] -> Set Name
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
_ = [Char] -> Q Exp
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 (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isUpper) Char
c = [Char] -> Q Exp
forall a. HasCallStack => [Char] -> a
error ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char]
"Custom command name must start with a capital letter: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
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]
_) -> () -> Q ()
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            [ArgType]
_ -> [Char] -> Q ()
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 [ArgType] -> [ArgType]
forall a. HasCallStack => [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]
_ ->
                    [Char] -> Q Exp
forall a. HasCallStack => [Char] -> a
error ([Char] -> Q Exp) -> [Char] -> Q Exp
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 $(Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE ([Char] -> Lit
StringL [Char]
customFunctionName))))
                        (mkCommandOptions ($(Q Exp
nargs) : copts))
                    , $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
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 = 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 $(Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE ([Char] -> Lit
StringL (Name -> [Char]
uppercaseFirstCharacter Name
functionName))))) sync acmdOpts, $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
fun))|]
        [ArgType]
_ ->
            [Char] -> Q Exp
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 <- (Type -> Q ArgType) -> Cxt -> Q [ArgType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> Q ArgType
classifyArgType (Cxt -> Q [ArgType]) -> Cxt -> Q [ArgType]
forall a b. (a -> b) -> a -> b
$ case Info
fInfo of
        VarI Name
_ Type
functionType Maybe Dec
_ ->
            Type -> Cxt
determineNumberOfArguments Type
functionType
        Info
x ->
            [Char] -> Cxt
forall a. HasCallStack => [Char] -> a
error ([Char] -> Cxt) -> [Char] -> Cxt
forall a b. (a -> b) -> a -> b
$ [Char]
"Value given to function is (likely) not the name of a function.\n" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Info -> [Char]
forall a. Show a => a -> [Char]
show Info
x

    Exp
e <- [ArgType] -> Q Exp
topLevelCase [ArgType]
nargs
    ([ArgType], Exp) -> Q ([ArgType], Exp)
forall a. a -> Q a
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 Type -> Cxt -> Cxt
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 = [ArgType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ArgType]
ts
            minLength :: Int
minLength = [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | Optional ArgType
_ <- [ArgType] -> [ArgType]
forall a. [a] -> [a]
reverse [ArgType]
ts]
        Name
args <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"args"
        [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE
            [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
args]
            ( Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE
                (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
args)
                ((Int -> Int -> Q Match) -> [Int] -> [Int] -> [Q Match]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Int -> Q Match
matchingCase [Int
n, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 ..] [Int
0 .. Int
minLength] [Q Match] -> [Q Match] -> [Q Match]
forall a. [a] -> [a] -> [a]
++ [Q Match
errorCase])
            )

    -- _ -> err "Wrong number of arguments"
    errorCase :: Q Match
    errorCase :: Q Match
errorCase =
        Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
            Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP
            ( Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
                [|
                    throw . ErrorMessage . pretty $
                        "Wrong number of arguments for function: "
                            ++ $(Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE ([Char] -> Lit
StringL (Name -> [Char]
nameBase Name
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 <- (Int -> Q (Maybe Name)) -> [Int] -> Q [Maybe Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\Int
_ -> Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Q Name -> Q (Maybe Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x") [Int
1 .. Int
n]
        let optVars :: [Maybe Name]
optVars = Int -> Maybe Name -> [Maybe Name]
forall a. Int -> a -> [a]
replicate Int
x (Maybe Name
forall a. Maybe a
Nothing :: Maybe Name)
        Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
            (([Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => [m Pat] -> m Pat
listP ([Q Pat] -> Q Pat)
-> ([Maybe Name] -> [Q Pat]) -> [Maybe Name] -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP ([Name] -> [Q Pat])
-> ([Maybe Name] -> [Name]) -> [Maybe Name] -> [Q Pat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Name] -> [Name]
forall a. [Maybe a] -> [a]
catMaybes) [Maybe Name]
vars)
            ( Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
                ( Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE
                    ( (Q Exp -> (Maybe Name, Q Exp) -> Q Exp)
-> Q Exp -> [(Maybe Name, Q Exp)] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
                        Q Exp -> (Maybe Name, Q Exp) -> Q Exp
genArgumentCast
                        [|pure $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
functionName)|]
                        ([Maybe Name] -> [Q Exp] -> [(Maybe Name, Q Exp)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Maybe Name]
vars [Maybe Name] -> [Maybe Name] -> [Maybe Name]
forall a. [a] -> [a] -> [a]
++ [Maybe Name]
optVars) (Q Exp -> [Q Exp]
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) ->
            Maybe (Q Exp) -> Q Exp -> Maybe (Q Exp) -> Q Exp
forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just Q Exp
e) Q Exp
op (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just [|fromObject $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v)|])
        (Maybe Name
Nothing, Q Exp
op) ->
            Maybe (Q Exp) -> Q Exp -> Maybe (Q Exp) -> Q Exp
forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just Q Exp
e) Q Exp
op (Q Exp -> Maybe (Q Exp)
forall a. a -> Maybe a
Just [|pure Nothing|])

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