{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}
module Neovim.API.TH
( generateAPI
, function
, function'
, command
, command'
, autocmd
, defaultAPITypeToHaskellTypeMap
, 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 (..),
FunctionalityDescription (..),
FunctionName(..),
mkCommandOptions)
import Neovim.Plugin.Internal (ExportedFunctionality (..))
import Neovim.RPC.FunctionCall
import Language.Haskell.TH
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 ((<+>), Doc, viaShow, Pretty(..))
import UnliftIO.Exception
import Prelude
dataD' :: CxtQ -> Name -> [TyVarBndr] -> [ConQ] -> [Name] -> DecQ
#if __GLASGOW_HASKELL__ < 800
dataD' = dataD
#elif __GLASGOW_HASKELL__ < 802
dataD' cxtQ n tyvarbndrs conq ns =
dataD cxtQ n tyvarbndrs Nothing conq (mapM conT ns)
#else
dataD' cxtQ n tyvarbndrs conq ns =
dataD cxtQ n tyvarbndrs Nothing conq ((return . return . DerivClause Nothing . map ConT) ns)
#endif
generateAPI :: Map String (Q Type) -> Q [Dec]
generateAPI typeMap = do
api <- either (fail . show) return =<< runIO parseAPI
let exceptionName = mkName "NeovimExceptionGen"
exceptions = (\(n,i) -> (mkName ("Neovim" <> n), i)) `map` errorTypes api
customTypesN = first mkName `map` customTypes api
join <$> sequence
[ fmap (join . return) $ createDataTypeWithByteStringComponent exceptionName (map fst exceptions)
, exceptionInstance exceptionName
, customTypeInstance exceptionName exceptions
, fmap join . mapM (\n -> createDataTypeWithByteStringComponent n [n]) $ (map 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 NeovimException|]
| otherwise = id
callFns | async nf && canFail nf = [ [|acall|] ]
| async nf = [ [|acall'|] ]
| canFail nf = [ [|scall|], [|scallThrow|] ]
| otherwise = [ [|scall'|] ]
functionNames = map mkName [ name nf, name nf ++ "'" ]
toObjVar v = [|toObject $(varE v)|]
retTypes <- let env = (mkName "env")
createSig retTypeFun =
forallT [PlainTV env] (return [])
. appT ([t|Neovim $(varT env) |])
. withDeferred . retTypeFun
. apiTypeToHaskellType typeMap $ returnType nf
in mapM createSig [ withException', id ]
let prefixWithNumber i n = "arg" ++ show i ++ "_" ++ n
applyPrefixWithNumber = zipWith (\i (t,n) -> (t, prefixWithNumber i n))
[0 :: Int ..] . parameters
vars <- mapM (\(t,n) -> (,) <$> apiTypeToHaskellType typeMap t
<*> newName n)
$ applyPrefixWithNumber nf
let impl functionName callFn retType =
[ sigD functionName . return
. foldr (AppT . AppT ArrowT) retType $ 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)))
[]
]
]
sequence . concat $ zipWith3 impl functionNames callFns retTypes
createDataTypeWithByteStringComponent :: Name -> [Name] -> Q [Dec]
createDataTypeWithByteStringComponent nme cs = do
tObject <- [t|ByteString|]
#if __GLASGOW_HASKELL__ < 800
let strictNess = (IsStrict, tObject)
#else
let strictNess = (Bang NoSourceUnpackedness SourceStrict, tObject)
#endif
sequence
[ dataD'
(return [])
nme
[]
(map (\n-> normalC n [return strictNess]) cs)
(mkName <$> ["Typeable", "Eq", "Show", "Generic"])
, instanceD (return []) (appT (conT (mkName "NFData")) (conT nme)) []
]
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 [|throwError $
pretty "Object is not convertible to:"
<+> viaShow n
<+> pretty "Received:" <+> viaShow $(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 a more 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
#if __GLASGOW_HASKELL__ < 800
VarI _ functionType _ _ ->
#else
VarI _ functionType _ ->
#endif
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,n-1..] [0..minLength] ++ [errorCase]))
errorCase :: Q Match
errorCase = match wildP
(normalB [|throw . ErrorMessage . pretty $ "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) :: Doc AnsiStyle)|])
[]