{-# OPTIONS_GHC -fno-warn-orphans #-}

module Ribosome.Plugin.TH.Handler where

import Control.Exception (throw)
import Data.MessagePack (Object)
import Data.Text.Prettyprint.Doc (Doc, Pretty(..))
import Data.Text.Prettyprint.Doc.Render.Terminal (AnsiStyle)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (Lift(..))
import Neovim.Exceptions (NeovimException(ErrorMessage))
import Neovim.Plugin.Classes (
  AutocmdOptions(AutocmdOptions),
  CommandOption(..),
  CommandOptions,
  RangeSpecification(..),
  Synchronous(..),
  )
import qualified Text.Show as Show (Show(show))

import Ribosome.Msgpack.Decode (fromMsgpack)
import Ribosome.Msgpack.Encode (toMsgpack)

data RpcHandlerConfig =
  RpcHandlerConfig {
    RpcHandlerConfig -> Synchronous
rhcSync :: Synchronous,
    RpcHandlerConfig -> Maybe Text
rhcName :: Maybe Text,
    RpcHandlerConfig -> Maybe [CommandOption]
rhcCmd :: Maybe [CommandOption],
    RpcHandlerConfig -> Maybe Text
rhcAutocmd :: Maybe Text,
    RpcHandlerConfig -> Maybe AutocmdOptions
rhcAutocmdOptions :: Maybe AutocmdOptions
  }
  deriving (RpcHandlerConfig -> RpcHandlerConfig -> Bool
(RpcHandlerConfig -> RpcHandlerConfig -> Bool)
-> (RpcHandlerConfig -> RpcHandlerConfig -> Bool)
-> Eq RpcHandlerConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RpcHandlerConfig -> RpcHandlerConfig -> Bool
$c/= :: RpcHandlerConfig -> RpcHandlerConfig -> Bool
== :: RpcHandlerConfig -> RpcHandlerConfig -> Bool
$c== :: RpcHandlerConfig -> RpcHandlerConfig -> Bool
Eq, Int -> RpcHandlerConfig -> ShowS
[RpcHandlerConfig] -> ShowS
RpcHandlerConfig -> String
(Int -> RpcHandlerConfig -> ShowS)
-> (RpcHandlerConfig -> String)
-> ([RpcHandlerConfig] -> ShowS)
-> Show RpcHandlerConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RpcHandlerConfig] -> ShowS
$cshowList :: [RpcHandlerConfig] -> ShowS
show :: RpcHandlerConfig -> String
$cshow :: RpcHandlerConfig -> String
showsPrec :: Int -> RpcHandlerConfig -> ShowS
$cshowsPrec :: Int -> RpcHandlerConfig -> ShowS
Show)

defaultRpcHandlerConfig :: RpcHandlerConfig
defaultRpcHandlerConfig :: RpcHandlerConfig
defaultRpcHandlerConfig =
  Synchronous
-> Maybe Text
-> Maybe [CommandOption]
-> Maybe Text
-> Maybe AutocmdOptions
-> RpcHandlerConfig
RpcHandlerConfig Synchronous
Async Maybe Text
forall a. Maybe a
Nothing Maybe [CommandOption]
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing Maybe AutocmdOptions
forall a. Maybe a
Nothing

data RpcDefDetail =
  RpcFunction { RpcDefDetail -> Synchronous
rfSync :: Synchronous }
  |
  RpcCommand { RpcDefDetail -> CommandOptions
rcOptions :: CommandOptions }
  |
  RpcAutocmd {
    RpcDefDetail -> Text
raEvent :: Text,
    RpcDefDetail -> Synchronous
raSync :: Synchronous,
    RpcDefDetail -> AutocmdOptions
raOptions :: AutocmdOptions
    }
  deriving Int -> RpcDefDetail -> ShowS
[RpcDefDetail] -> ShowS
RpcDefDetail -> String
(Int -> RpcDefDetail -> ShowS)
-> (RpcDefDetail -> String)
-> ([RpcDefDetail] -> ShowS)
-> Show RpcDefDetail
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RpcDefDetail] -> ShowS
$cshowList :: [RpcDefDetail] -> ShowS
show :: RpcDefDetail -> String
$cshow :: RpcDefDetail -> String
showsPrec :: Int -> RpcDefDetail -> ShowS
$cshowsPrec :: Int -> RpcDefDetail -> ShowS
Show

data RpcDef m =
  RpcDef {
    RpcDef m -> RpcDefDetail
rdDetail :: RpcDefDetail,
    RpcDef m -> Text
rdName :: Text,
    RpcDef m -> [Object] -> m Object
rdHandler :: [Object] -> m Object
  }

instance Show (RpcDef m) where
  show :: RpcDef m -> String
show (RpcDef RpcDefDetail
d Text
n [Object] -> m Object
_) =
    String
"RpcDef" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (RpcDefDetail, Text) -> String
forall b a. (Show a, IsString b) => a -> b
show (RpcDefDetail
d, Text
n)

deriving instance Lift Synchronous

deriving instance Lift RangeSpecification

deriving instance Lift CommandOption

deriving instance Lift AutocmdOptions

unfoldFunctionParams :: Type -> [Type]
unfoldFunctionParams :: Type -> [Type]
unfoldFunctionParams (ForallT [TyVarBndr]
_ [Type]
_ Type
t) =
  Type -> [Type]
unfoldFunctionParams Type
t
unfoldFunctionParams (AppT (AppT Type
ArrowT Type
t) Type
r) =
  Type
t Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type -> [Type]
unfoldFunctionParams Type
r
unfoldFunctionParams Type
_ = []

functionParamTypes :: Name -> Q [Type]
functionParamTypes :: Name -> Q [Type]
functionParamTypes Name
name =
  Name -> Q Info
reify Name
name Q Info -> (Info -> [Type]) -> Q [Type]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    (VarI Name
_ Type
functionType Maybe Dec
_) -> Type -> [Type]
unfoldFunctionParams Type
functionType
    Info
_ -> String -> [Type]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> [Type]) -> String -> [Type]
forall a b. (a -> b) -> a -> b
$ String
"rpc handler `" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall b a. (Show a, IsString b) => a -> b
show Name
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"` is not a function"

errorBody :: Name -> BodyQ
errorBody :: Name -> BodyQ
errorBody Name
rpcName =
  Q Exp -> BodyQ
normalB [|throw . ErrorMessage . pretty $ ($(errLit) :: String)|]
  where
    errLit :: Q Exp
errLit =
      Lit -> Q Exp
litE (String -> Lit
StringL String
errMsg)
    errMsg :: String
errMsg =
      String
"Wrong number of arguments for rpc handler: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name -> String
nameBase Name
rpcName

errorCase :: Name -> Q Match
errorCase :: Name -> Q Match
errorCase Name
rpcName =
  PatQ -> BodyQ -> [DecQ] -> Q Match
match PatQ
wildP (Name -> BodyQ
errorBody Name
rpcName) []

failedEvaluation :: Q Match
failedEvaluation :: Q Match
failedEvaluation = do
  Name
e <- String -> Q Name
newName String
"e"
  PatQ -> BodyQ -> [DecQ] -> Q Match
match (Name -> [PatQ] -> PatQ
conP (String -> Name
mkName String
"Left") [Name -> PatQ
varP Name
e]) (Q Exp -> BodyQ
normalB [|throw . ErrorMessage $ ($(varE e) :: Doc AnsiStyle)|]) []

successfulEvaluation :: Q Match
successfulEvaluation :: Q Match
successfulEvaluation = do
  Name
action <- String -> Q Name
newName String
"action"
  PatQ -> BodyQ -> [DecQ] -> Q Match
match (Name -> [PatQ] -> PatQ
conP (String -> Name
mkName String
"Right") [Name -> PatQ
varP Name
action]) (Q Exp -> BodyQ
normalB [|toMsgpack <$> $(varE action)|]) []

dispatchCase :: PatQ -> ExpQ -> Q Match
dispatchCase :: PatQ -> Q Exp -> Q Match
dispatchCase PatQ
params Q Exp
dispatch =
  PatQ -> BodyQ -> [DecQ] -> Q Match
match PatQ
params (Q Exp -> BodyQ
normalB (Q Exp -> [Q Match] -> Q Exp
caseE Q Exp
dispatch [Q Match]
resultCases)) []
  where
    resultCases :: [Q Match]
resultCases = [Q Match
Item [Q Match]
successfulEvaluation, Q Match
Item [Q Match]
failedEvaluation]

handlerCall :: Name -> [ExpQ] -> ExpQ
handlerCall :: Name -> [Q Exp] -> Q Exp
handlerCall Name
handlerName =
  (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Exp -> Q Exp
decodeSeq [|pure $(varE handlerName)|]
  where
    decodeSeq :: Q Exp -> Q Exp -> Q Exp
decodeSeq Q Exp
z = Q Exp -> Q Exp -> Q Exp -> Q Exp
infixApp Q Exp
z [|(<*>)|]

decodedCallSequence :: Name -> [ExpQ] -> ExpQ
decodedCallSequence :: Name -> [Q Exp] -> Q Exp
decodedCallSequence Name
handlerName [Q Exp]
vars =
  Name -> [Q Exp] -> Q Exp
handlerCall Name
handlerName (Q Exp -> Q Exp
decoded (Q Exp -> Q Exp) -> [Q Exp] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Exp]
vars)
  where
    decoded :: Q Exp -> Q Exp
decoded Q Exp
a =
      [|fromMsgpack $(a)|]

argsCase :: Name -> PatQ -> [Name] -> Q Match
argsCase :: Name -> PatQ -> [Name] -> Q Match
argsCase Name
handlerName PatQ
params [Name]
paramNames =
  PatQ -> Q Exp -> Q Match
dispatchCase PatQ
params Q Exp
dispatch
  where
    dispatch :: Q Exp
dispatch = Name -> [Q Exp] -> Q Exp
decodedCallSequence Name
handlerName [Q Exp]
paramVars
    paramVars :: [Q Exp]
paramVars = Name -> Q Exp
varE (Name -> Q Exp) -> [Name] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
paramNames

rpcLambda :: Q Match -> Maybe (Q Match) -> ExpQ
rpcLambda :: Q Match -> Maybe (Q Match) -> Q Exp
rpcLambda Q Match
matchingArgsCase Maybe (Q Match)
errorCase' = do
  Name
args <- String -> Q Name
newName String
"args"
  [PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
args] [|$(caseE (varE args) (matchingArgsCase : maybeToList errorCase'))|]

rpcLambdaWithErrorCase :: Name -> Q Match -> ExpQ
rpcLambdaWithErrorCase :: Name -> Q Match -> Q Exp
rpcLambdaWithErrorCase Name
funcName Q Match
matchingArgsCase =
  Q Match -> Maybe (Q Match) -> Q Exp
rpcLambda Q Match
matchingArgsCase (Maybe (Q Match) -> Q Exp) -> Maybe (Q Match) -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Match -> Maybe (Q Match)
forall a. a -> Maybe a
Just (Name -> Q Match
errorCase Name
funcName)

rpcLambdaWithoutErrorCase :: Q Match -> ExpQ
rpcLambdaWithoutErrorCase :: Q Match -> Q Exp
rpcLambdaWithoutErrorCase Q Match
matchingArgsCase =
  Q Match -> Maybe (Q Match) -> Q Exp
rpcLambda Q Match
matchingArgsCase Maybe (Q Match)
forall a. Maybe a
Nothing

listParamsPattern :: [Name] -> PatQ
listParamsPattern :: [Name] -> PatQ
listParamsPattern =
  [PatQ] -> PatQ
listP ([PatQ] -> PatQ) -> ([Name] -> [PatQ]) -> [Name] -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> PatQ
varP (Name -> PatQ) -> [Name] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)

lambdaNames :: Int -> Q [Name]
lambdaNames :: Int -> Q [Name]
lambdaNames Int
count =
  Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
count (String -> Q Name
newName String
"a")