module Neovim.API.TH
( generateAPI
, function
, function'
, command
, command'
, autocmd
, defaultAPITypeToHaskellTypeMap
, module Control.Exception.Lifted
, 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 (..),
ExportedFunctionality (..),
FunctionalityDescription (..),
mkCommandOptions)
import Neovim.RPC.FunctionCall
import Language.Haskell.TH
import Control.Applicative
import Control.Arrow
import Control.Concurrent.STM (STM)
import Control.Exception
import Control.Exception.Lifted
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, pack)
import Prelude
generateAPI :: Map String (Q Type) -> Q [Dec]
generateAPI typeMap = do
api <- either fail return =<< runIO parseAPI
let exceptionName = mkName "NeovimExceptionGen"
exceptions = (\(n,i) -> (mkName ("Neovim" <> n), i)) <$> errorTypes api
customTypesN = first mkName <$> customTypes api
join <$> sequence
[ fmap return . createDataTypeWithByteStringComponent exceptionName $ fst <$> exceptions
, exceptionInstance exceptionName
, customTypeInstance exceptionName exceptions
, mapM (\n -> createDataTypeWithByteStringComponent n [n]) $ fst <$> customTypesN
, join <$> mapM (\(n,i) -> customTypeInstance n [(n,i)]) customTypesN
, fmap join . mapM (createFunction typeMap) $ functions api
]
defaultAPITypeToHaskellTypeMap :: Map String (Q Type)
defaultAPITypeToHaskellTypeMap = Map.fromList
[ ("Boolean" , [t|Bool|])
, ("Integer" , [t|Int64|])
, ("Float" , [t|Double|])
, ("Array" , [t|[Object]|])
, ("Dictionary", [t|Map Object Object|])
, ("void" , [t|()|])
]
apiTypeToHaskellType :: Map String (Q Type) -> NeovimType -> Q Type
apiTypeToHaskellType typeMap at = case at of
Void -> [t|()|]
NestedType t Nothing ->
appT listT $ apiTypeToHaskellType typeMap t
NestedType t (Just n) ->
foldl appT (tupleT n) . replicate n $ apiTypeToHaskellType typeMap t
SimpleType t ->
fromMaybe ((conT . mkName) t) $ Map.lookup t typeMap
createFunction :: Map String (Q Type) -> NeovimFunction -> Q [Dec]
createFunction typeMap nf = do
let withDeferred | deferred nf = appT [t|STM|]
| otherwise = id
withException | canFail nf = appT [t|Either Object|]
| otherwise = id
callFn | deferred nf && canFail nf = [|acall|]
| deferred nf = [|acall'|]
| canFail nf = [|scall|]
| otherwise = [|scall'|]
functionName = (mkName . name) nf
toObjVar v = [|toObject $(varE v)|]
ret <- let (r,st) = (mkName "r", mkName "st")
in forallT [PlainTV r, PlainTV st] (return [])
. appT ([t|Neovim $(varT r) $(varT st) |])
. withDeferred . withException
. apiTypeToHaskellType typeMap $ returnType nf
vars <- mapM (\(t,n) -> (,) <$> apiTypeToHaskellType typeMap t
<*> newName n)
$ parameters nf
sequence
[ sigD functionName . return
. foldr (AppT . AppT ArrowT) ret $ map fst vars
, funD functionName
[ clause
(map (varP . snd) vars)
(normalB (callFn
`appE` ([| pack |] `appE` (litE . stringL . name) nf)
`appE` listE (map (toObjVar . snd) vars)))
[]
]
]
createDataTypeWithByteStringComponent :: Name -> [Name] -> Q Dec
createDataTypeWithByteStringComponent nme cs = do
tObject <- [t|ByteString|]
dataD
(return [])
nme
[]
(map (\n-> normalC n [return (IsStrict, tObject)]) cs)
(mkName <$> ["Typeable", "Eq", "Show"])
exceptionInstance :: Name -> Q [Dec]
exceptionInstance exceptionName = return <$>
instanceD
(return [])
([t|Exception|] `appT` conT exceptionName)
[]
customTypeInstance :: Name -> [(Name, Int64)] -> Q [Dec]
customTypeInstance typeName nis =
let fromObjectClause :: Name -> Int64 -> Q Clause
fromObjectClause n i = newName "bs" >>= \bs ->
clause
[ conP (mkName "ObjectExt")
[(litP . integerL . fromIntegral) i,varP bs]
]
(normalB [|return $ $(conE n) $(varE bs)|])
[]
fromObjectErrorClause :: Q Clause
fromObjectErrorClause = do
o <- newName "o"
let n = nameBase typeName
clause
[ varP o ]
(normalB [|Left $ "Object is not convertible to: " <> n <> " Received: " <> show $(varE o)|])
[]
toObjectClause :: Name -> Int64 -> Q Clause
toObjectClause n i = newName "bs" >>= \bs ->
clause
[conP n [varP bs]]
(normalB [|ObjectExt $((litE . integerL . fromIntegral) i) $(varE bs)|])
[]
in return <$> instanceD
(return [])
([t|NvimObject|] `appT` conT typeName)
[ funD (mkName "toObject") $ map (uncurry toObjectClause) nis
, funD (mkName "fromObject")
$ map (uncurry fromObjectClause) nis
<> [fromObjectErrorClause]
]
function :: String -> Name -> Q Exp
function [] _ = error "Empty names are not allowed for exported functions."
function customName@(c:_) functionName
| (not . isUpper) c = error $ "Custom function name must start with a capiatl letter: " <> show customName
| otherwise = do
(_, fun) <- functionImplementation functionName
[|\funOpts -> EF (Function (pack $(litE (StringL customName))) funOpts, $(return fun)) |]
function' :: Name -> Q Exp
function' functionName =
let (c:cs) = nameBase functionName
in function (toUpper c:cs) functionName
data ArgType = StringyType
| ListOfStringyTypes
| OptionalStringyType
| CommandArgumentsType
| OtherType
deriving (Eq, Ord, Show, Read, Enum, Bounded)
classifyArgType :: Type -> Q ArgType
classifyArgType t = do
set <- genStringTypesSet
maybeType <- [t|Maybe|]
cmdArgsType <- [t|CommandArguments|]
return $ case t of
AppT ListT (ConT str) | str `Set.member` set
-> ListOfStringyTypes
AppT m (ConT str) | m == maybeType && str `Set.member` set
-> OptionalStringyType
ConT str | str `Set.member` set
-> StringyType
cmd | cmd == cmdArgsType
-> CommandArgumentsType
_ -> OtherType
where
genStringTypesSet = do
types <- sequence [[t|String|],[t|ByteString|],[t|Text|]]
return $ Set.fromList [ n | ConT n <- types ]
command :: String -> Name -> Q Exp
command [] _ = error "Empty names are not allowed for exported commands."
command customFunctionName@(c:_) functionName
| (not . isUpper) c = error $ "Custom command name must start with a capiatl letter: " <> show customFunctionName
| otherwise = do
(argTypes, fun) <- functionImplementation functionName
cts <- mapM classifyArgType argTypes
case cts of
(CommandArgumentsType:_) -> return ()
_ -> error "First argument for a function exported as a command must be CommandArguments!"
let nargs = case tail cts of
[] -> [|CmdNargs "0"|]
[StringyType] -> [|CmdNargs "1"|]
[OptionalStringyType] -> [|CmdNargs "?"|]
[ListOfStringyTypes] -> [|CmdNargs "*"|]
[StringyType, ListOfStringyTypes] -> [|CmdNargs "+"|]
_ -> error $ unlines
[ "Trying to generate a command without compatible types."
, "Due to a limitation burdened on us by vimL, we can only"
, "use a limited amount type signatures for commands. See"
, "the documentation for 'command' for am ore thorough"
, "explanation."
]
[|\copts -> EF (Command
(pack $(litE (StringL customFunctionName)))
(mkCommandOptions ($(nargs) : copts))
, $(return fun))|]
command' :: Name -> Q Exp
command' functionName =
let (c:cs) = nameBase functionName
in command (toUpper c:cs) functionName
autocmd :: Name -> Q Exp
autocmd functionName =
let (c:cs) = nameBase functionName
in do
(_, fun) <- functionImplementation functionName
[|\t acmdOpts -> EF (Autocmd t (pack $(litE (StringL (toUpper c : cs)))) acmdOpts, $(return fun))|]
functionImplementation :: Name -> Q ([Type], Exp)
functionImplementation functionName = do
fInfo <- reify functionName
let nargs = case fInfo of
VarI _ functionType _ _ -> determineNumberOfArguments functionType
x -> error $ "Value given to function is (likely) not the name of a function.\n"
<> show x
e <- topLevelCase (length nargs)
return (nargs, e)
where
determineNumberOfArguments :: Type -> [Type]
determineNumberOfArguments ft = case ft of
ForallT _ _ t -> determineNumberOfArguments t
AppT (AppT ArrowT t) r -> t : determineNumberOfArguments r
_ -> []
topLevelCase :: Int -> Q Exp
topLevelCase n = newName "args" >>= \args ->
lamE [varP args] (caseE (varE args) [matchingCase n, errorCase])
errorCase :: Q Match
errorCase = match wildP
(normalB [|err $ "Wrong number of arguments for function: "
++ $(litE (StringL (nameBase functionName))) |]) []
matchingCase :: Int -> Q Match
matchingCase n = mapM (\_ -> newName "x") [1..n] >>= \vars ->
match (listP (map varP vars))
(normalB
(caseE
(foldl genArgumentCast [|pure $(varE functionName)|]
(zip vars (repeat [|(<*>)|])))
[successfulEvaluation, failedEvaluation]))
[]
genArgumentCast :: Q Exp -> (Name, Q Exp) -> Q Exp
genArgumentCast e (v,op) = infixE (Just e) op (Just [|fromObject $(varE v)|])
successfulEvaluation :: Q Match
successfulEvaluation = newName "action" >>= \action ->
match (conP (mkName "Right") [varP action])
(normalB [|toObject <$> $(varE action)|])
[]
failedEvaluation :: Q Match
failedEvaluation = newName "e" >>= \e ->
match (conP (mkName "Left") [varP e])
(normalB [|err $(varE e)|])
[]