{-# LANGUAGE LambdaCase #-}
{-# 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 (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
generateAPI :: TypeMap -> Q [Dec]
generateAPI :: TypeMap -> Q [Dec]
generateAPI TypeMap
typeMap = do
NeovimAPI
api <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. IO a -> Q a
runIO IO (Either (Doc AnsiStyle) NeovimAPI)
parseAPI
let exceptionName :: Name
exceptionName = [Char] -> Name
mkName [Char]
"NeovimExceptionGen"
exceptions :: [(Name, Int64)]
exceptions = (\([Char]
n, Int64
i) -> ([Char] -> Name
mkName ([Char]
"Neovim" forall a. Semigroup a => a -> a -> a
<> [Char]
n), Int64
i)) forall a b. (a -> b) -> [a] -> [b]
`map` NeovimAPI -> [([Char], Int64)]
errorTypes NeovimAPI
api
customTypesN :: [(Name, Int64)]
customTypesN = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first [Char] -> Name
mkName forall a b. (a -> b) -> [a] -> [b]
`map` NeovimAPI -> [([Char], Int64)]
customTypes NeovimAPI
api
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> [Name] -> Q [Dec]
createDataTypeWithByteStringComponent Name
exceptionName (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Name, Int64)]
exceptions)
, Name -> Q [Dec]
exceptionInstance Name
exceptionName
, Name -> [(Name, Int64)] -> Q [Dec]
customTypeInstance Name
exceptionName [(Name, Int64)]
exceptions
, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((\Name
n -> Name -> [Name] -> Q [Dec]
createDataTypeWithByteStringComponent Name
n [Name
n]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Name, Int64)]
customTypesN)
, forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Name
n, Int64
i) -> Name -> [(Name, Int64)] -> Q [Dec]
customTypeInstance Name
n [(Name
n, Int64
i)]) [(Name, Int64)]
customTypesN
, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TypeMap -> NeovimFunction -> Q [Dec]
createFunction TypeMap
typeMap) forall a b. (a -> b) -> a -> b
$ NeovimAPI -> [NeovimFunction]
functions NeovimAPI
api
]
data TypeMap = TypeMap
{ TypeMap -> Map [Char] (Q Type)
typesOfAPI :: Map String (Q Type)
, TypeMap -> Q Type
list :: Q Type
}
stringListTypeMap :: TypeMap
stringListTypeMap :: TypeMap
stringListTypeMap =
TypeMap
{ typesOfAPI :: Map [Char] (Q Type)
typesOfAPI =
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ ([Char]
"Boolean", [t|Bool|])
, ([Char]
"Integer", [t|Int64|])
, ([Char]
"LuaRef", [t|Int64|])
, ([Char]
"Float", [t|Double|])
, ([Char]
"String", [t|String|])
, ([Char]
"Array", [t|[Object]|])
, ([Char]
"Dictionary", [t|Map String Object|])
, ([Char]
"void", [t|()|])
]
, list :: Q Type
list = forall (m :: * -> *). Quote m => m Type
listT
}
textVectorTypeMap :: TypeMap
textVectorTypeMap :: TypeMap
textVectorTypeMap =
TypeMap
stringListTypeMap
{ typesOfAPI :: Map [Char] (Q Type)
typesOfAPI = Map [Char] (Q Type) -> Map [Char] (Q Type)
adjustTypeMapForText forall a b. (a -> b) -> a -> b
$ TypeMap -> Map [Char] (Q Type)
typesOfAPI TypeMap
stringListTypeMap
, list :: Q Type
list = [t|Vector|]
}
where
adjustTypeMapForText :: Map [Char] (Q Type) -> Map [Char] (Q Type)
adjustTypeMapForText =
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
"String" [t|Text|]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
"Array" [t|Vector Object|]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
"Dictionary" [t|Map Text Object|]
bytestringVectorTypeMap :: TypeMap
bytestringVectorTypeMap :: TypeMap
bytestringVectorTypeMap =
TypeMap
textVectorTypeMap
{ typesOfAPI :: Map [Char] (Q Type)
typesOfAPI = Map [Char] (Q Type) -> Map [Char] (Q Type)
adjustTypeMapForByteString forall a b. (a -> b) -> a -> b
$ TypeMap -> Map [Char] (Q Type)
typesOfAPI TypeMap
textVectorTypeMap
}
where
adjustTypeMapForByteString :: Map [Char] (Q Type) -> Map [Char] (Q Type)
adjustTypeMapForByteString =
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
"String" [t|ByteString|]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
"Array" [t|Vector Object|]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
"Dictionary" [t|Map ByteString Object|]
apiTypeToHaskellType :: TypeMap -> NeovimType -> Q Type
apiTypeToHaskellType :: TypeMap -> NeovimType -> Q Type
apiTypeToHaskellType typeMap :: TypeMap
typeMap@TypeMap{Map [Char] (Q Type)
typesOfAPI :: Map [Char] (Q Type)
typesOfAPI :: TypeMap -> Map [Char] (Q Type)
typesOfAPI, Q Type
list :: Q Type
list :: TypeMap -> Q Type
list} NeovimType
at = case NeovimType
at of
NeovimType
Void -> [t|()|]
NestedType NeovimType
t Maybe Int
Nothing ->
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT Q Type
list forall a b. (a -> b) -> a -> b
$ TypeMap -> NeovimType -> Q Type
apiTypeToHaskellType TypeMap
typeMap NeovimType
t
NestedType NeovimType
t (Just Int
n) ->
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Int -> m Type
tupleT Int
n) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> a -> [a]
replicate Int
n forall a b. (a -> b) -> a -> b
$ TypeMap -> NeovimType -> Q Type
apiTypeToHaskellType TypeMap
typeMap NeovimType
t
SimpleType [Char]
t ->
forall a. a -> Maybe a -> a
fromMaybe ((forall (m :: * -> *). Quote m => Name -> m Type
conT forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Name
mkName) [Char]
t) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
t Map [Char] (Q Type)
typesOfAPI
createFunction :: TypeMap -> NeovimFunction -> Q [Dec]
createFunction :: TypeMap -> NeovimFunction -> Q [Dec]
createFunction TypeMap
typeMap NeovimFunction
nf = do
let withDeferred :: Q Type -> Q Type
withDeferred
| NeovimFunction -> Bool
async NeovimFunction
nf = forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT [t|STM|] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT [t|Either NeovimException|]
| Bool
otherwise = forall a. a -> a
id
callFn :: Q Exp
callFn
| NeovimFunction -> Bool
async NeovimFunction
nf = [|acall|]
| Bool
otherwise = [|scall'|]
functionName :: Name
functionName = [Char] -> Name
mkName forall a b. (a -> b) -> a -> b
$ NeovimFunction -> [Char]
name NeovimFunction
nf
toObjVar :: Name -> m Exp
toObjVar Name
v = [|toObject $(varE v)|]
let env :: Name
env = [Char] -> Name
mkName [Char]
"env"
Type
retType <- forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT [t|Neovim $(varT env)|]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Type -> Q Type
withDeferred
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeMap -> NeovimType -> Q Type
apiTypeToHaskellType TypeMap
typeMap
forall a b. (a -> b) -> a -> b
$ NeovimFunction -> NeovimType
returnType NeovimFunction
nf
let prefixWithNumber :: a -> [Char] -> [Char]
prefixWithNumber a
i [Char]
n = [Char]
"arg" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
i forall a. [a] -> [a] -> [a]
++ [Char]
"_" forall a. [a] -> [a] -> [a]
++ [Char]
n
applyPrefixWithNumber :: NeovimFunction -> [(NeovimType, [Char])]
applyPrefixWithNumber =
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
(\Int
i (NeovimType
t, [Char]
n) -> (NeovimType
t, forall {a}. Show a => a -> [Char] -> [Char]
prefixWithNumber Int
i [Char]
n))
[Int
0 :: Int ..]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NeovimFunction -> [(NeovimType, [Char])]
parameters
[(Type, Name)]
vars <-
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
( \(NeovimType
t, [Char]
n) ->
(,)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeMap -> NeovimType -> Q Type
apiTypeToHaskellType TypeMap
typeMap NeovimType
t
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
n
)
forall a b. (a -> b) -> a -> b
$ NeovimFunction -> [(NeovimType, [Char])]
applyPrefixWithNumber NeovimFunction
nf
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ (forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
functionName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TyVarBndr Specificity] -> Cxt -> Type -> Type
ForallT [Name -> TyVarBndr Specificity
specifiedPlainTV Name
env] []
forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Type -> Type -> Type
AppT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT Type
ArrowT) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) Type
retType [(Type, Name)]
vars
, forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD
Name
functionName
[ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
(forall a b. (a -> b) -> [a] -> [b]
map (forall (m :: * -> *). Quote m => Name -> m Pat
varP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Type, Name)]
vars)
( forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
( Q Exp
callFn
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ([|(F . T.pack)|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Lit
stringL forall b c a. (b -> c) -> (a -> b) -> a -> c
. NeovimFunction -> [Char]
name) NeovimFunction
nf)
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE (forall a b. (a -> b) -> [a] -> [b]
map (forall {m :: * -> *}. Quote m => Name -> m Exp
toObjVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Type, Name)]
vars)
)
)
[]
]
]
createDataTypeWithByteStringComponent :: Name -> [Name] -> Q [Dec]
createDataTypeWithByteStringComponent :: Name -> [Name] -> Q [Dec]
createDataTypeWithByteStringComponent Name
nme [Name]
cs = do
Type
tObject <- [t|ByteString|]
let strictNess :: (Bang, Type)
strictNess = (SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
SourceStrict, Type
tObject)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
[ Cxt -> Name -> [UnitTyVarBndr] -> [Con] -> [Name] -> Dec
dataD
[]
Name
nme
[]
(forall a b. (a -> b) -> [a] -> [b]
map (\Name
n -> Name -> [(Bang, Type)] -> Con
NormalC Name
n [(Bang, Type)
strictNess]) [Name]
cs)
([Char] -> Name
mkName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Char]
"Typeable", [Char]
"Eq", [Char]
"Show", [Char]
"Generic"])
, Cxt -> Type -> [Dec] -> Dec
instanceD [] (Type -> Type -> Type
AppT (Name -> Type
ConT ([Char] -> Name
mkName [Char]
"NFData")) (Name -> Type
ConT Name
nme)) []
]
exceptionInstance :: Name -> Q [Dec]
exceptionInstance :: Name -> Q [Dec]
exceptionInstance Name
exceptionName = do
Type
tException <- [t|Exception|]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Cxt -> Type -> [Dec] -> Dec
instanceD [] (Type
tException Type -> Type -> Type
`AppT` Name -> Type
ConT Name
exceptionName) []]
customTypeInstance :: Name -> [(Name, Int64)] -> Q [Dec]
customTypeInstance :: Name -> [(Name, Int64)] -> Q [Dec]
customTypeInstance Name
typeName [(Name, Int64)]
nis = do
let fromObjectClause :: Name -> Int64 -> Q Clause
fromObjectClause :: Name -> Int64 -> Q Clause
fromObjectClause Name
n Int64
i = do
Name
bs <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"bs"
let objectExtMatch :: Pat
objectExtMatch =
Name -> [Pat] -> Pat
conP
([Char] -> Name
mkName [Char]
"ObjectExt")
[(Lit -> Pat
LitP forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
integerL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) Int64
i, Name -> Pat
VarP Name
bs]
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
[forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
objectExtMatch]
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|return $ $(conE n) $(varE bs)|])
[]
fromObjectErrorClause :: Q Clause
fromObjectErrorClause :: Q Clause
fromObjectErrorClause = do
Name
o <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"o"
let n :: [Char]
n = Name -> [Char]
nameBase Name
typeName
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
[forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
o]
( forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
[|
throwError $
pretty "Object is not convertible to:"
<+> viaShow n
<+> pretty "Received:"
<+> viaShow $(varE o)
|]
)
[]
toObjectClause :: Name -> Int64 -> Q Clause
toObjectClause :: Name -> Int64 -> Q Clause
toObjectClause Name
n Int64
i = do
Name
bs <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"bs"
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
[forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [Pat] -> Pat
conP Name
n [Name -> Pat
VarP Name
bs])]
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|ObjectExt $((litE . integerL . fromIntegral) i) $(varE bs)|])
[]
Type
tNvimObject <- [t|NvimObject|]
Dec
fToObject <- forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ([Char] -> Name
mkName [Char]
"toObject") forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> Int64 -> Q Clause
toObjectClause) [(Name, Int64)]
nis
Dec
fFromObject <- forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ([Char] -> Name
mkName [Char]
"fromObject") forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> Int64 -> Q Clause
fromObjectClause) [(Name, Int64)]
nis forall a. Semigroup a => a -> a -> a
<> [Q Clause
fromObjectErrorClause]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Cxt -> Type -> [Dec] -> Dec
instanceD [] (Type
tNvimObject Type -> Type -> Type
`AppT` Name -> Type
ConT Name
typeName) [Dec
fToObject, Dec
fFromObject]]
function :: String -> Name -> Q Exp
function :: [Char] -> Name -> Q Exp
function [] Name
_ = forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Empty names are not allowed for exported functions."
function customName :: [Char]
customName@(Char
c : [Char]
_) Name
functionName
| (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isUpper) Char
c = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Custom function name must start with a capital letter: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [Char]
customName
| Bool
otherwise = do
([ArgType]
_, Exp
fun) <- Name -> Q ([ArgType], Exp)
functionImplementation Name
functionName
[|\funOpts -> EF (Function (F (T.pack $(litE (StringL customName)))) funOpts, $(return fun))|]
uppercaseFirstCharacter :: Name -> String
uppercaseFirstCharacter :: Name -> [Char]
uppercaseFirstCharacter Name
name = case Name -> [Char]
nameBase Name
name of
[Char]
"" -> [Char]
""
(Char
c : [Char]
cs) -> Char -> Char
toUpper Char
c forall a. a -> [a] -> [a]
: [Char]
cs
function' :: Name -> Q Exp
function' :: Name -> Q Exp
function' Name
functionName = [Char] -> Name -> Q Exp
function (Name -> [Char]
uppercaseFirstCharacter Name
functionName) Name
functionName
data ArgType
= StringyType
| ListOfStringyTypes
| Optional ArgType
| CommandArgumentsType
| OtherType
deriving (ArgType -> ArgType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ArgType -> ArgType -> Bool
$c/= :: ArgType -> ArgType -> Bool
== :: ArgType -> ArgType -> Bool
$c== :: ArgType -> ArgType -> Bool
Eq, Eq ArgType
ArgType -> ArgType -> Bool
ArgType -> ArgType -> Ordering
ArgType -> ArgType -> ArgType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ArgType -> ArgType -> ArgType
$cmin :: ArgType -> ArgType -> ArgType
max :: ArgType -> ArgType -> ArgType
$cmax :: ArgType -> ArgType -> ArgType
>= :: ArgType -> ArgType -> Bool
$c>= :: ArgType -> ArgType -> Bool
> :: ArgType -> ArgType -> Bool
$c> :: ArgType -> ArgType -> Bool
<= :: ArgType -> ArgType -> Bool
$c<= :: ArgType -> ArgType -> Bool
< :: ArgType -> ArgType -> Bool
$c< :: ArgType -> ArgType -> Bool
compare :: ArgType -> ArgType -> Ordering
$ccompare :: ArgType -> ArgType -> Ordering
Ord, Int -> ArgType -> [Char] -> [Char]
[ArgType] -> [Char] -> [Char]
ArgType -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [ArgType] -> [Char] -> [Char]
$cshowList :: [ArgType] -> [Char] -> [Char]
show :: ArgType -> [Char]
$cshow :: ArgType -> [Char]
showsPrec :: Int -> ArgType -> [Char] -> [Char]
$cshowsPrec :: Int -> ArgType -> [Char] -> [Char]
Show, ReadPrec [ArgType]
ReadPrec ArgType
Int -> ReadS ArgType
ReadS [ArgType]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ArgType]
$creadListPrec :: ReadPrec [ArgType]
readPrec :: ReadPrec ArgType
$creadPrec :: ReadPrec ArgType
readList :: ReadS [ArgType]
$creadList :: ReadS [ArgType]
readsPrec :: Int -> ReadS ArgType
$creadsPrec :: Int -> ReadS ArgType
Read)
classifyArgType :: Type -> Q ArgType
classifyArgType :: Type -> Q ArgType
classifyArgType Type
t = do
Set Name
set <- Q (Set Name)
genStringTypesSet
Type
maybeType <- [t|Maybe|]
Type
cmdArgsType <- [t|CommandArguments|]
case Type
t of
AppT Type
ListT (ConT Name
str)
| Name
str forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
set ->
forall (m :: * -> *) a. Monad m => a -> m a
return ArgType
ListOfStringyTypes
AppT Type
m mt :: Type
mt@(ConT Name
_)
| Type
m forall a. Eq a => a -> a -> Bool
== Type
maybeType ->
ArgType -> ArgType
Optional forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q ArgType
classifyArgType Type
mt
ConT Name
str
| Name
str forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
set ->
forall (m :: * -> *) a. Monad m => a -> m a
return ArgType
StringyType
Type
cmd
| Type
cmd forall a. Eq a => a -> a -> Bool
== Type
cmdArgsType ->
forall (m :: * -> *) a. Monad m => a -> m a
return ArgType
CommandArgumentsType
Type
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ArgType
OtherType
where
genStringTypesSet :: Q (Set Name)
genStringTypesSet = do
Cxt
types <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [[t|String|], [t|ByteString|], [t|Text|]]
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [Name
n | ConT Name
n <- Cxt
types]
command :: String -> Name -> Q Exp
command :: [Char] -> Name -> Q Exp
command [] Name
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"Empty names are not allowed for exported commands."
command customFunctionName :: [Char]
customFunctionName@(Char
c : [Char]
_) Name
functionName
| (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isUpper) Char
c = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Custom command name must start with a capital letter: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [Char]
customFunctionName
| Bool
otherwise = do
([ArgType]
argTypes, Exp
fun) <- Name -> Q ([ArgType], Exp)
functionImplementation Name
functionName
case [ArgType]
argTypes of
(ArgType
CommandArgumentsType : [ArgType]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
[ArgType]
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"First argument for a function exported as a command must be CommandArguments!"
let nargs :: Q Exp
nargs = case forall a. [a] -> [a]
tail [ArgType]
argTypes of
[] -> [|CmdNargs "0"|]
[ArgType
StringyType] -> [|CmdNargs "1"|]
[Optional ArgType
StringyType] -> [|CmdNargs "?"|]
[ArgType
ListOfStringyTypes] -> [|CmdNargs "*"|]
[ArgType
StringyType, ArgType
ListOfStringyTypes] -> [|CmdNargs "+"|]
[ArgType]
_ ->
forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$
[[Char]] -> [Char]
unlines
[ [Char]
"Trying to generate a command without compatible types."
, [Char]
"Due to a limitation burdened on us by vimL, we can only"
, [Char]
"use a limited amount type signatures for commands. See"
, [Char]
"the documentation for 'command' for a more thorough"
, [Char]
"explanation."
]
[|
\copts ->
EF
( Command
(F (T.pack $(litE (StringL customFunctionName))))
(mkCommandOptions ($(nargs) : copts))
, $(return fun)
)
|]
command' :: Name -> Q Exp
command' :: Name -> Q Exp
command' Name
functionName = [Char] -> Name -> Q Exp
command (Name -> [Char]
uppercaseFirstCharacter Name
functionName) Name
functionName
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 $(litE (StringL (uppercaseFirstCharacter functionName))))) sync acmdOpts, $(return fun))|]
[ArgType]
_ ->
forall a. HasCallStack => [Char] -> a
error [Char]
"Autocmd functions have to be fully applied (i.e. they should not take any arguments)."
functionImplementation :: Name -> Q ([ArgType], Exp)
functionImplementation :: Name -> Q ([ArgType], Exp)
functionImplementation Name
functionName = do
Info
fInfo <- Name -> Q Info
reify Name
functionName
[ArgType]
nargs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q ArgType
classifyArgType forall a b. (a -> b) -> a -> b
$ case Info
fInfo of
VarI Name
_ Type
functionType Maybe Dec
_ ->
Type -> Cxt
determineNumberOfArguments Type
functionType
Info
x ->
forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Value given to function is (likely) not the name of a function.\n" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Info
x
Exp
e <- [ArgType] -> Q Exp
topLevelCase [ArgType]
nargs
forall (m :: * -> *) a. Monad m => a -> m a
return ([ArgType]
nargs, Exp
e)
where
determineNumberOfArguments :: Type -> [Type]
determineNumberOfArguments :: Type -> Cxt
determineNumberOfArguments Type
ft = case Type
ft of
ForallT [TyVarBndr Specificity]
_ Cxt
_ Type
t -> Type -> Cxt
determineNumberOfArguments Type
t
AppT (AppT Type
ArrowT Type
t) Type
r -> Type
t forall a. a -> [a] -> [a]
: Type -> Cxt
determineNumberOfArguments Type
r
Type
_ -> []
topLevelCase :: [ArgType] -> Q Exp
topLevelCase :: [ArgType] -> Q Exp
topLevelCase [ArgType]
ts = do
let n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length [ArgType]
ts
minLength :: Int
minLength = forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | Optional ArgType
_ <- forall a. [a] -> [a]
reverse [ArgType]
ts]
Name
args <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"args"
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE
[forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
args]
( forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE
(forall {m :: * -> *}. Quote m => Name -> m Exp
varE Name
args)
(forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Int -> Q Match
matchingCase [Int
n, Int
n forall a. Num a => a -> a -> a
- Int
1 ..] [Int
0 .. Int
minLength] forall a. [a] -> [a] -> [a]
++ [Q Match
errorCase])
)
errorCase :: Q Match
errorCase :: Q Match
errorCase =
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
forall (m :: * -> *). Quote m => m Pat
wildP
( forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
[|
throw . ErrorMessage . pretty $
"Wrong number of arguments for function: "
++ $(litE (StringL (nameBase functionName)))
|]
)
[]
matchingCase :: Int -> Int -> Q Match
matchingCase :: Int -> Int -> Q Match
matchingCase Int
n Int
x = do
[Maybe Name]
vars <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Int
_ -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x") [Int
1 .. Int
n]
let optVars :: [Maybe Name]
optVars = forall a. Int -> a -> [a]
replicate Int
x (forall a. Maybe a
Nothing :: Maybe Name)
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
((forall (m :: * -> *). Quote m => [m Pat] -> m Pat
listP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes) [Maybe Name]
vars)
( forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
( forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE
( forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
Q Exp -> (Maybe Name, Q Exp) -> Q Exp
genArgumentCast
[|pure $(varE functionName)|]
(forall a b. [a] -> [b] -> [(a, b)]
zip ([Maybe Name]
vars forall a. [a] -> [a] -> [a]
++ [Maybe Name]
optVars) (forall a. a -> [a]
repeat [|(<*>)|]))
)
[Q Match
successfulEvaluation, Q Match
failedEvaluation]
)
)
[]
genArgumentCast :: Q Exp -> (Maybe Name, Q Exp) -> Q Exp
genArgumentCast :: Q Exp -> (Maybe Name, Q Exp) -> Q Exp
genArgumentCast Q Exp
e = \case
(Just Name
v, Q Exp
op) ->
forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE (forall a. a -> Maybe a
Just Q Exp
e) Q Exp
op (forall a. a -> Maybe a
Just [|fromObject $(varE v)|])
(Maybe Name
Nothing, Q Exp
op) ->
forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE (forall a. a -> Maybe a
Just Q Exp
e) Q Exp
op (forall a. a -> Maybe a
Just [|pure Nothing|])
successfulEvaluation :: Q Match
successfulEvaluation :: Q Match
successfulEvaluation =
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"action" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Name
action ->
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
(forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [Pat] -> Pat
conP ([Char] -> Name
mkName [Char]
"Right") [Name -> Pat
VarP Name
action]))
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|toObject <$> $(varE action)|])
[]
failedEvaluation :: Q Match
failedEvaluation :: Q Match
failedEvaluation =
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"e" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Name
e ->
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
(forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [Pat] -> Pat
conP ([Char] -> Name
mkName [Char]
"Left") [Name -> Pat
VarP Name
e]))
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|err ($(varE e) :: Doc AnsiStyle)|])
[]