{-# 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 (dataD, instanceD, conP)
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.ByteString.UTF8 (fromString)
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.Text.Prettyprint.Doc (viaShow)
import Data.Vector (Vector)
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 (String -> Q NeovimAPI
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q NeovimAPI)
-> (Doc AnsiStyle -> String) -> Doc AnsiStyle -> Q NeovimAPI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc AnsiStyle -> String
forall a. Show a => a -> String
show) NeovimAPI -> Q NeovimAPI
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 = String -> Name
mkName String
"NeovimExceptionGen"
        exceptions :: [(Name, Int64)]
exceptions = (\(String
n, Int64
i) -> (String -> Name
mkName (String
"Neovim" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
n), Int64
i)) ((String, Int64) -> (Name, Int64))
-> [(String, Int64)] -> [(Name, Int64)]
forall a b. (a -> b) -> [a] -> [b]
`map` NeovimAPI -> [(String, Int64)]
errorTypes NeovimAPI
api
        customTypesN :: [(Name, Int64)]
customTypesN = (String -> Name) -> (String, Int64) -> (Name, Int64)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first String -> Name
mkName ((String, Int64) -> (Name, Int64))
-> [(String, Int64)] -> [(Name, Int64)]
forall a b. (a -> b) -> [a] -> [b]
`map` NeovimAPI -> [(String, 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)
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 (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 (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)
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)
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 (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)
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 String (Q Type)
typesOfAPI :: Map String (Q Type)
    , TypeMap -> Q Type
list :: Q Type
    }

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

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

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

apiTypeToHaskellType :: TypeMap -> NeovimType -> Q Type
apiTypeToHaskellType :: TypeMap -> NeovimType -> Q Type
apiTypeToHaskellType typeMap :: TypeMap
typeMap@TypeMap{Map String (Q Type)
typesOfAPI :: Map String (Q Type)
typesOfAPI :: TypeMap -> Map String (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 ->
        Q Type -> Q Type -> Q 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 (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
appT (Int -> Q 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 String
t ->
        Q Type -> Maybe (Q Type) -> Q Type
forall a. a -> Maybe a -> a
fromMaybe ((Name -> Q Type
conT (Name -> Q Type) -> (String -> Name) -> String -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName) String
t) (Maybe (Q Type) -> Q Type) -> Maybe (Q Type) -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Map String (Q Type) -> Maybe (Q Type)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
t Map String (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
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
appT [t|Either NeovimException|]
            | Bool
otherwise = Q Type -> Q Type
forall a. a -> a
id

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

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

    Type
retType <-
        let env :: Name
env = String -> Name
mkName String
"env"
         in [TyVarBndr] -> CxtQ -> Q Type -> Q Type
forallT [Name -> TyVarBndr
specifiedPlainTV Name
env] ([Type] -> CxtQ
forall (m :: * -> *) a. Monad m => a -> m a
return [])
                (Q Type -> Q Type)
-> (NeovimType -> Q Type) -> NeovimType -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Type -> Q Type -> Q Type
appT [t|Neovim $(varT 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 -> String -> String
prefixWithNumber a
i String
n = String
"arg" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n
        applyPrefixWithNumber :: NeovimFunction -> [(NeovimType, String)]
applyPrefixWithNumber =
            (Int -> (NeovimType, String) -> (NeovimType, String))
-> [Int] -> [(NeovimType, String)] -> [(NeovimType, String)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
                (\Int
i (NeovimType
t, String
n) -> (NeovimType
t, Int -> String -> String
forall a. Show a => a -> String -> String
prefixWithNumber Int
i String
n))
                [Int
0 :: Int ..]
                ([(NeovimType, String)] -> [(NeovimType, String)])
-> (NeovimFunction -> [(NeovimType, String)])
-> NeovimFunction
-> [(NeovimType, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NeovimFunction -> [(NeovimType, String)]
parameters
    [(Type, Name)]
vars <-
        ((NeovimType, String) -> Q (Type, Name))
-> [(NeovimType, String)] -> Q [(Type, Name)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
            ( \(NeovimType
t, String
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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Q Name
newName String
n
            )
            ([(NeovimType, String)] -> Q [(Type, Name)])
-> [(NeovimType, String)] -> Q [(Type, Name)]
forall a b. (a -> b) -> a -> b
$ NeovimFunction -> [(NeovimType, String)]
applyPrefixWithNumber NeovimFunction
nf

    [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
        [ (Name -> Q Type -> Q 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 (m :: * -> *) a. Monad m => a -> m a
return) (((Type, Name) -> Type -> Type) -> Type -> [(Type, Name)] -> Type
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 -> [ClauseQ] -> Q Dec
funD
            Name
functionName
            [ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause
                (((Type, Name) -> PatQ) -> [(Type, Name)] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> PatQ
varP (Name -> PatQ) -> ((Type, Name) -> Name) -> (Type, Name) -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type, Name) -> Name
forall a b. (a, b) -> b
snd) [(Type, Name)]
vars)
                ( ExpQ -> BodyQ
normalB
                    ( ExpQ
callFn
                        ExpQ -> ExpQ -> ExpQ
`appE` ([|(F . fromString)|] ExpQ -> ExpQ -> ExpQ
`appE` (Lit -> ExpQ
litE (Lit -> ExpQ) -> (NeovimFunction -> Lit) -> NeovimFunction -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
stringL (String -> Lit)
-> (NeovimFunction -> String) -> NeovimFunction -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NeovimFunction -> String
name) NeovimFunction
nf)
                        ExpQ -> ExpQ -> ExpQ
`appE` [ExpQ] -> ExpQ
listE (((Type, Name) -> ExpQ) -> [(Type, Name)] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> ExpQ
toObjVar (Name -> ExpQ) -> ((Type, Name) -> Name) -> (Type, Name) -> ExpQ
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 (f :: * -> *) a. Applicative f => a -> f a
pure
        [ [Type] -> Name -> [TyVarBndr] -> [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)
            (String -> Name
mkName (String -> Name) -> [String] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String
"Typeable", String
"Eq", String
"Show", String
"Generic"])
        , [Type] -> Type -> [Dec] -> Dec
instanceD [] (Type -> Type -> Type
AppT (Name -> Type
ConT (String -> Name
mkName String
"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 (f :: * -> *) a. Applicative f => a -> f a
pure [[Type] -> 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 -> ClauseQ
fromObjectClause Name
n Int64
i = do
            Name
bs <- String -> Q Name
newName String
"bs"
            let objectExtMatch :: Pat
objectExtMatch = Name -> [Pat] -> Pat
conP
                        (String -> Name
mkName String
"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]
            [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause
                [ Pat -> PatQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
objectExtMatch ]
                (ExpQ -> BodyQ
normalB [|return $ $(conE n) $(varE bs)|])
                []
        fromObjectErrorClause :: Q Clause
        fromObjectErrorClause :: ClauseQ
fromObjectErrorClause = do
            Name
o <- String -> Q Name
newName String
"o"
            let n :: String
n = Name -> String
nameBase Name
typeName
            [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause
                [Name -> PatQ
varP Name
o]
                ( ExpQ -> BodyQ
normalB
                    [|
                        throwError $
                            pretty "Object is not convertible to:"
                                <+> viaShow n
                                <+> pretty "Received:"
                                <+> viaShow $(varE o)
                        |]
                )
                []

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

    Type
tNvimObject <- [t|NvimObject|]
    Dec
fToObject <- Name -> [ClauseQ] -> Q Dec
funD (String -> Name
mkName String
"toObject") ([ClauseQ] -> Q Dec) -> [ClauseQ] -> Q Dec
forall a b. (a -> b) -> a -> b
$ ((Name, Int64) -> ClauseQ) -> [(Name, Int64)] -> [ClauseQ]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> Int64 -> ClauseQ) -> (Name, Int64) -> ClauseQ
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> Int64 -> ClauseQ
toObjectClause) [(Name, Int64)]
nis
    Dec
fFromObject <- Name -> [ClauseQ] -> Q Dec
funD (String -> Name
mkName String
"fromObject") ([ClauseQ] -> Q Dec) -> [ClauseQ] -> Q Dec
forall a b. (a -> b) -> a -> b
$ ((Name, Int64) -> ClauseQ) -> [(Name, Int64)] -> [ClauseQ]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> Int64 -> ClauseQ) -> (Name, Int64) -> ClauseQ
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> Int64 -> ClauseQ
fromObjectClause) [(Name, Int64)]
nis [ClauseQ] -> [ClauseQ] -> [ClauseQ]
forall a. Semigroup a => a -> a -> a
<> [ClauseQ
fromObjectErrorClause]
    [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Type] -> 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 :: String -> Name -> ExpQ
function [] Name
_ = String -> ExpQ
forall a. HasCallStack => String -> a
error String
"Empty names are not allowed for exported functions."
function customName :: String
customName@(Char
c : String
_) 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 = String -> ExpQ
forall a. HasCallStack => String -> a
error (String -> ExpQ) -> String -> ExpQ
forall a b. (a -> b) -> a -> b
$ String
"Custom function name must start with a capiatl letter: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
customName
    | Bool
otherwise = do
        ([ArgType]
_, Exp
fun) <- Name -> Q ([ArgType], Exp)
functionImplementation Name
functionName
        [|\funOpts -> EF (Function (F (fromString $(litE (StringL customName)))) funOpts, $(return fun))|]

{- | 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 -> ExpQ
function' Name
functionName =
    let (Char
c : String
cs) = Name -> String
nameBase Name
functionName
     in String -> Name -> ExpQ
function (Char -> Char
toUpper Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
cs) 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
/= :: ArgType -> ArgType -> Bool
$c/= :: ArgType -> ArgType -> Bool
== :: ArgType -> ArgType -> Bool
$c== :: 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
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
$cp1Ord :: Eq ArgType
Ord, Int -> ArgType -> String -> String
[ArgType] -> String -> String
ArgType -> String
(Int -> ArgType -> String -> String)
-> (ArgType -> String)
-> ([ArgType] -> String -> String)
-> Show ArgType
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ArgType] -> String -> String
$cshowList :: [ArgType] -> String -> String
show :: ArgType -> String
$cshow :: ArgType -> String
showsPrec :: Int -> ArgType -> String -> String
$cshowsPrec :: Int -> ArgType -> String -> String
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
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 Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
set ->
                ArgType -> Q ArgType
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 (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 (m :: * -> *) a. Monad m => a -> m a
return ArgType
CommandArgumentsType
        Type
_ -> ArgType -> Q ArgType
forall (m :: * -> *) a. Monad m => a -> m a
return ArgType
OtherType
  where
    genStringTypesSet :: Q (Set Name)
genStringTypesSet = do
        [Type]
types <- [Q Type] -> CxtQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [[t|String|], [t|ByteString|], [t|Text|]]
        Set Name -> Q (Set Name)
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 <- [Type]
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 :: String -> Name -> ExpQ
command [] Name
_ = String -> ExpQ
forall a. HasCallStack => String -> a
error String
"Empty names are not allowed for exported commands."
command customFunctionName :: String
customFunctionName@(Char
c : String
_) 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 = String -> ExpQ
forall a. HasCallStack => String -> a
error (String -> ExpQ) -> String -> ExpQ
forall a b. (a -> b) -> a -> b
$ String
"Custom command name must start with a capital letter: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
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 (m :: * -> *) a. Monad m => a -> m a
return ()
            [ArgType]
_ -> String -> Q ()
forall a. HasCallStack => String -> a
error String
"First argument for a function exported as a command must be CommandArguments!"
        let nargs :: ExpQ
nargs = case [ArgType] -> [ArgType]
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]
_ ->
                    String -> ExpQ
forall a. HasCallStack => String -> a
error (String -> ExpQ) -> String -> ExpQ
forall a b. (a -> b) -> a -> b
$
                        [String] -> String
unlines
                            [ String
"Trying to generate a command without compatible types."
                            , String
"Due to a limitation burdened on us by vimL, we can only"
                            , String
"use a limited amount type signatures for commands. See"
                            , String
"the documentation for 'command' for a more thorough"
                            , String
"explanation."
                            ]
        [|
            \copts ->
                EF
                    ( Command
                        (F (fromString $(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 -> ExpQ
command' Name
functionName =
    let (Char
c : String
cs) = Name -> String
nameBase Name
functionName
     in String -> Name -> ExpQ
command (Char -> Char
toUpper Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
cs) 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 -> ExpQ
autocmd Name
functionName =
    let (Char
c : String
cs) = Name -> String
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 (fromString $(litE (StringL (toUpper c : cs))))) sync acmdOpts, $(return fun))|]
                [ArgType]
_ ->
                    String -> ExpQ
forall a. HasCallStack => String -> a
error String
"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) -> [Type] -> Q [ArgType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q ArgType
classifyArgType ([Type] -> Q [ArgType]) -> [Type] -> Q [ArgType]
forall a b. (a -> b) -> a -> b
$ case Info
fInfo of
        VarI Name
_ Type
functionType Maybe Dec
_ ->
            Type -> [Type]
determineNumberOfArguments Type
functionType
        Info
x ->
            String -> [Type]
forall a. HasCallStack => String -> a
error (String -> [Type]) -> String -> [Type]
forall a b. (a -> b) -> a -> b
$ String
"Value given to function is (likely) not the name of a function.\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Info -> String
forall a. Show a => a -> String
show Info
x

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

    -- _ -> err "Wrong number of arguments"
    errorCase :: Q Match
    errorCase :: MatchQ
errorCase =
        PatQ -> BodyQ -> [Q Dec] -> MatchQ
match
            PatQ
wildP
            ( ExpQ -> BodyQ
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 -> MatchQ
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)
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
<$> String -> Q Name
newName String
"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)
        PatQ -> BodyQ -> [Q Dec] -> MatchQ
match
            (([PatQ] -> PatQ
listP ([PatQ] -> PatQ)
-> ([Maybe Name] -> [PatQ]) -> [Maybe Name] -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP ([Name] -> [PatQ])
-> ([Maybe Name] -> [Name]) -> [Maybe Name] -> [PatQ]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Name] -> [Name]
forall a. [Maybe a] -> [a]
catMaybes) [Maybe Name]
vars)
            ( ExpQ -> BodyQ
normalB
                ( ExpQ -> [MatchQ] -> ExpQ
caseE
                    ( (ExpQ -> (Maybe Name, ExpQ) -> ExpQ)
-> ExpQ -> [(Maybe Name, ExpQ)] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
                        ExpQ -> (Maybe Name, ExpQ) -> ExpQ
genArgumentCast
                        [|pure $(varE functionName)|]
                        ([Maybe Name] -> [ExpQ] -> [(Maybe Name, ExpQ)]
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) (ExpQ -> [ExpQ]
forall a. a -> [a]
repeat [|(<*>)|]))
                    )
                    [MatchQ
successfulEvaluation, MatchQ
failedEvaluation]
                )
            )
            []

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

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