{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}
module Neovim.API.TH
( generateAPI
, function
, function'
, command
, command'
, autocmd
, stringListTypeMap
, textVectorTypeMap
, bytestringVectorTypeMap
, 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 Data.Vector (Vector)
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 :: TypeMap -> 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
]
data TypeMap = TypeMap
{ typesOfAPI :: Map String (Q Type)
, list :: Q Type
}
stringListTypeMap :: TypeMap
stringListTypeMap = TypeMap
{ typesOfAPI = Map.fromList
[ ("Boolean" , [t|Bool|])
, ("Integer" , [t|Int64|])
, ("Float" , [t|Double|])
, ("String" , [t|String|])
, ("Array" , [t|[Object]|])
, ("Dictionary", [t|Map String Object|])
, ("void" , [t|()|])
]
, list = listT
}
textVectorTypeMap :: TypeMap
textVectorTypeMap = stringListTypeMap
{ typesOfAPI = adjustTypeMapForText $ typesOfAPI stringListTypeMap
, list = [t|Vector|]
}
where
adjustTypeMapForText =
Map.insert "String" [t|Text|] .
Map.insert "Array" [t|Vector Object|] .
Map.insert "Dictionary" [t|Map Text Object|]
bytestringVectorTypeMap :: TypeMap
bytestringVectorTypeMap = textVectorTypeMap
{ typesOfAPI = adjustTypeMapForByteString $ typesOfAPI textVectorTypeMap
}
where
adjustTypeMapForByteString =
Map.insert "String" [t|ByteString|] .
Map.insert "Array" [t|Vector Object|] .
Map.insert "Dictionary" [t|Map ByteString Object|]
apiTypeToHaskellType :: TypeMap -> NeovimType -> Q Type
apiTypeToHaskellType typeMap@TypeMap{typesOfAPI,list} at = case at of
Void -> [t|()|]
NestedType t Nothing ->
appT list $ 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 typesOfAPI
createFunction :: TypeMap -> NeovimFunction -> Q [Dec]
createFunction typeMap nf = do
let withDeferred | async nf = appT [t|STM|]
| otherwise = id
callFn | async nf = [|acall'|]
| otherwise = [|scall'|]
functionName = mkName $ name nf
toObjVar v = [|toObject $(varE v)|]
retType <- let env = (mkName "env")
in forallT [PlainTV env] (return [])
. appT ([t|Neovim $(varT env) |])
. withDeferred
. apiTypeToHaskellType typeMap $ returnType nf
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
sequence
[ 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)))
[]
]
]
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 capital 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 sync acmdOpts -> EF (Autocmd t (F (fromString $(litE (StringL (toUpper c : cs))))) sync 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)|])
[]