{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE CPP #-}
{- |
Module      :  Neovim.API.TH
Description :  Template Haskell API generation module
Copyright   :  (c) Sebastian Witte
License     :  Apache-2.0

Maintainer  :  woozletoff@gmail.com
Stability   :  experimental

-}
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

-- | Generate the API types and functions provided by @nvim --api-info@.
--
-- The provided map allows the use of different Haskell types for the types
-- defined in the API. The types must be an instance of 'NvimObject' and they
-- must form an isomorphism with the sent messages types. Currently, it
-- provides a Convenient way to replace the /String/ type with 'Text',
-- 'ByteString' or 'String'.
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
        ]


-- | Default type mappings for the requested 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


-- | This function will create a wrapper function with neovim's function name
-- as its name.
--
-- Synchronous function:
-- @
-- buffer_get_number :: Buffer -> Neovim Int64
-- buffer_get_number buffer = scall "buffer_get_number" [toObject buffer]
-- @
--
-- Asynchronous function:
-- @
-- vim_eval :: String -> Neovim (TMVar Object)
-- vim_eval str = acall "vim_eval" [toObject str]
-- @
--
-- Asynchronous function without a return value:
-- @
-- vim_feed_keys :: String -> String -> Bool -> Neovim ()
-- vim_feed_keys keys mode escape_csi =
--     acallVoid "vim_feed_keys" [ toObject keys
--                               , toObject mode
--                               , toObject escape_csi
--                               ]
-- @
--
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 ]

    vars <- mapM (\(t,n) -> (,) <$> apiTypeToHaskellType typeMap t
                                <*> newName n)
            $ parameters 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


-- | @ createDataTypeWithObjectComponent SomeName [Foo,Bar]@
-- will create this:
-- @
-- data SomeName = Foo !Object
--               | Bar !Object
--               deriving (Typeable, Eq, Show)
-- @
--
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)) []
            ]


-- | If the first parameter is @mkName NeovimException@, this function will
-- generate  @instance Exception NeovimException@.
exceptionInstance :: Name -> Q [Dec]
exceptionInstance exceptionName = return <$>
    instanceD
        (return [])
        ([t|Exception|] `appT` conT exceptionName)
        []


-- | @customTypeInstance Foo [(Bar, 1), (Quz, 2)]@
-- will create this:
-- @
-- instance Serializable Foo where
--     toObject (Bar bs) = ObjectExt 1 bs
--     toObject (Quz bs) = ObjectExt 2 bs
--     fromObject (ObjectExt 1 bs) = return $ Bar bs
--     fromObject (ObjectExt 2 bs) = return $ Quz bs
--     fromObject o = Left $ "Object is not convertible to: Foo Received: " <> show o
-- @
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]
        ]


-- | Define an exported function by providing a custom name and referencing the
-- function you want to export.
--
-- Note that the name must start with an upper case letter.
--
-- Example: @ $(function \"MyExportedFunction\" 'myDefinedFunction) 'Sync' @
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)) |]


-- | Define an exported function. This function works exactly like 'function',
-- but it generates the exported name automatically by converting the first
-- letter to upper case.
function' :: Name -> Q Exp
function' functionName =
    let (c:cs) = nameBase functionName
    in function (toUpper c:cs) functionName


-- | Simply data type used to identify a string-ish type (e.g. 'String', 'Text',
-- 'ByteString' for a value of type.
data ArgType = StringyType
             | ListOfStringyTypes
             | Optional ArgType
             | CommandArgumentsType
             | OtherType
             deriving (Eq, Ord, Show, Read)


-- | Given a value of type 'Type', test whether it can be classified according
-- to the constructors of "ArgType".
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 ]


-- | Similarly to 'function', this function is used to export a command with a
-- custom name.
--
-- Note that commands must start with an upper case letter.
--
-- Due to limitations on the side of (neo)vim, commands can only have one of the
-- following five signatures, where you can replace 'String' with 'ByteString'
-- or 'Text' if you wish:
--
-- * 'CommandArguments' -> 'Neovim' r st ()
--
-- * 'CommandArguments' -> 'Maybe' 'String' -> 'Neovim' r st ()
--
-- * 'CommandArguments' -> 'String' -> 'Neovim' r st ()
--
-- * 'CommandArguments' -> ['String'] -> 'Neovim' r st ()
--
-- * 'CommandArguments' -> 'String' -> ['String'] -> 'Neovim' r st ()
--
-- Example: @ $(command \"RememberThePrime\" 'someFunction) ['CmdBang'] @
--
-- Note that the list of command options (i.e. the last argument) removes
-- duplicate options by means of some internally convenient sorting. You should
-- simply not define the same option twice.
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
        -- See :help :command-nargs for what the result strings mean
        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))|]

-- | Define an exported command. This function works exactly like 'command', but
-- it generates the command name by converting the first letter to upper case.
command' :: Name -> Q Exp
command' functionName =
    let (c:cs) = nameBase functionName
    in command (toUpper c:cs) functionName


-- | This function generates an export for autocmd. Since this is a static
-- registration, arguments are not allowed here. You can, of course, define a
-- fully applied function and pass it as an argument. If you have to add
-- autocmds dynamically, it can be done with 'addAutocmd'.
--
-- Example:
--
-- @
-- someFunction :: a -> b -> c -> d -> Neovim r st res
-- someFunction = ...
--
-- theFunction :: Neovim r st res
-- theFunction = someFunction 1 2 3 4
--
-- $(autocmd 'theFunction) def
-- @
--
-- @def@ is of type 'AutocmdOptions'.
--
-- Note that you have to define @theFunction@ in a different module due to
-- the use of Template Haskell.
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)."


-- | Generate a function of type @[Object] -> Neovim' Object@ from the argument
-- function.
--
-- The function
-- @
-- add :: Int -> Int -> Int
-- add = (+)
-- @
-- will be converted to
-- @
-- \args -> case args of
--     [x,y] -> case pure add <*> fromObject x <*> fromObject y of
--         Left e -> err $ "Wrong type of arguments for add: " ++ e
--         Right action -> toObject <$> action
--     _ -> err $ "Wrong number of arguments for add: " ++ show xs
-- @
--
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
        _ -> []
    -- \args -> case args of ...
    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]))

    -- _ -> err "Wrong number of arguments"
    errorCase :: Q Match
    errorCase = match wildP
        (normalB [|throw . ErrorMessage . pretty $ "Wrong number of arguments for function: "
                        ++ $(litE (StringL (nameBase functionName))) |]) []

    -- [x,y] -> case pure add <*> fromObject x <*> fromObject y of ...
    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)|])
              []