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 (..),
FunctionalityDescription (..),
FunctionName(..),
mkCommandOptions)
import Neovim.Plugin.Internal (ExportedFunctionality (..))
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.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 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 | async nf = appT [t|STM|]
| otherwise = id
withException | canFail nf = appT [t|Either Object|]
| otherwise = id
callFn | async nf && canFail nf = [|acall|]
| async 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` ([| (F . fromString) |] `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 (F (fromString $(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
| Optional ArgType
| CommandArgumentsType
| OtherType
deriving (Eq, Ord, Show, Read)
classifyArgType :: Type -> Q ArgType
classifyArgType t = do
set <- genStringTypesSet
maybeType <- [t|Maybe|]
cmdArgsType <- [t|CommandArguments|]
case t of
AppT ListT (ConT str) | str `Set.member` set
-> return ListOfStringyTypes
AppT m mt@(ConT _) | m == maybeType
-> Optional <$> classifyArgType mt
ConT str | str `Set.member` set
-> return StringyType
cmd | cmd == cmdArgsType
-> return CommandArgumentsType
_ -> return 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
case argTypes of
(CommandArgumentsType:_) -> return ()
_ -> error "First argument for a function exported as a command must be CommandArguments!"
let nargs = case tail argTypes of
[] -> [|CmdNargs "0"|]
[StringyType] -> [|CmdNargs "1"|]
[Optional StringyType] -> [|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
(F (fromString $(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
(as, fun) <- functionImplementation functionName
case as of
[] ->
[|\t acmdOpts -> EF (Autocmd t (F (fromString $(litE (StringL (toUpper c : cs))))) acmdOpts, $(return fun))|]
_ ->
error "Autocmd functions have to be fully applied (i.e. they should not take any arguments)."
functionImplementation :: Name -> Q ([ArgType], Exp)
functionImplementation functionName = do
fInfo <- reify functionName
nargs <- mapM classifyArgType $ 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 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 :: [ArgType] -> Q Exp
topLevelCase ts = do
let n = length ts
minLength = length [ () | Optional _ <- reverse ts ]
args <- newName "args"
lamE [varP args] (caseE (varE args)
(zipWith matchingCase [n,n1..] [0..minLength] ++ [errorCase]))
errorCase :: Q Match
errorCase = match wildP
(normalB [|err $ "Wrong number of arguments for function: "
++ $(litE (StringL (nameBase functionName))) |]) []
matchingCase :: Int -> Int -> Q Match
matchingCase n x = do
vars <- mapM (\_ -> Just <$> newName "x") [1..n]
let optVars = replicate x (Nothing :: Maybe Name)
match ((listP . map varP . catMaybes) vars)
(normalB
(caseE
(foldl genArgumentCast [|pure $(varE functionName)|]
(zip (vars ++ optVars) (repeat [|(<*>)|])))
[successfulEvaluation, failedEvaluation]))
[]
genArgumentCast :: Q Exp -> (Maybe Name, Q Exp) -> Q Exp
genArgumentCast e = \case
(Just v,op) ->
infixE (Just e) op (Just [|fromObject $(varE v)|])
(Nothing, op) ->
infixE (Just e) op (Just [|pure Nothing|])
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)|])
[]