{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TemplateHaskell #-}
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
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
]
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
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
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)
)
)
[]
]
]
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)) []
]
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 :: 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]]
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))|]
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
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)
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]
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
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)
)
|]
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
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)."
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
_ -> []
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])
)
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)))
|]
)
[]
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)|])
[]