content: ----------------------------------------------------------------------------
  -- |
  -- Module      :  Data.Emacs.Module.Raw.Env.TH
  -- Copyright   :  (c) Sergey Vinokurov 2018
  -- License     :  Apache-2.0 (see LICENSE)
  -- Maintainer  :  serg.foo@gmail.com
  ----------------------------------------------------------------------------
  
  {-# LANGUAGE CPP                   #-}
  {-# LANGUAGE TemplateHaskellQuotes #-}
  
  module Data.Emacs.Module.Raw.Env.TH (wrapEmacsFunc, Safety(..)) where
  
  import Control.Monad.IO.Class
  import Data.Bifunctor
  import Data.List qualified as L
  import Foreign.Ptr as Foreign
  import Language.Haskell.TH
  
  import Data.Emacs.Module.Raw.Env.Internal as Env
  
  decomposeFunctionType :: Type -> ([Type], Type)
  decomposeFunctionType = go []
    where
      go :: [Type] -> Type -> ([Type], Type)
      go args = \case
        ForallT _ _ t          -> go args t
        AppT (AppT ArrowT x) y -> go (x : args) y
        ret                    -> (reverse args, ret)
  
  #if MIN_VERSION_template_haskell(2, 17, 0)
  unwrapForall :: Type -> (Maybe ([TyVarBndr Specificity], Cxt), Type)
  #else
  unwrapForall :: Type -> (Maybe ([TyVarBndr], Cxt), Type)
  #endif
  unwrapForall (ForallT bs c t) = (Just (bs, c), t)
  unwrapForall t                = (Nothing, t)
  
  #if MIN_VERSION_template_haskell(2, 17, 0)
  wrapForall :: Maybe ([TyVarBndr Specificity], Cxt) -> Type -> Type
  #else
  wrapForall :: Maybe ([TyVarBndr], Cxt) -> Type -> Type
  #endif
  wrapForall Nothing        = id
  wrapForall (Just (bs, c)) = ForallT bs c
  
  wrapEmacsFunc :: String -> Safety -> ExpQ -> TypeQ -> DecsQ
  wrapEmacsFunc name safety peekExpr rawFuncType = do
    rawFuncType' <- rawFuncType
    let (forallCxt, rawFuncType'') = unwrapForall rawFuncType'
        (args, ret)                = decomposeFunctionType rawFuncType''
    (envArg, otherArgs) <- case args of
      [] -> fail $
        "Raw function type must take at least one emacs_env argument: " ++ show rawFuncType'
      x : xs
       | x /= ConT ''Env.Env -> fail $
         "Raw function type must take emacs_env as a first argument, but takes " ++ show x ++ " in " ++ show rawFuncType'
       | otherwise ->
          (,) <$> newName "env" <*> traverse (const (newName "x")) xs
    foreignFuncName <- newName $ "emacs_func_" ++ name
    let envPat :: PatQ
        envPat = varP envArg
        pats   = envPat : map varP otherArgs
        body   = normalB $ do
          funPtrVar <- newName "funPtr"
          [e|liftIO|] `appE` doE
            [ bindS (varP funPtrVar) $ peekExpr `appE` ([e| Env.toPtr |] `appE` varE envArg)
            , noBindS $ L.foldl' appE (varE foreignFuncName) (map varE $ funPtrVar : envArg : otherArgs)
            ]
    m    <- newName "m"
    ret' <- case ret of
      AppT monad result
        | monad == ConT ''IO
        -> appT (varT m) (pure result)
      _ -> fail $ "Expected function that returns result in IO monad"
    let tv         = PlainTV m SpecifiedSpec
        constraint = ConT ''MonadIO `AppT` (VarT m)
    typeSig      <- sigD name' $ pure $
      wrapForall (Just (maybe ([tv], [constraint]) (bimap (tv :) (constraint :)) forallCxt)) $
        foldr (\x acc -> ArrowT `AppT` x `AppT` acc) ret' args
    mainDecl     <- funD name' [clause pats body []]
    inlinePragma <- pragInlD name' Inline FunLike AllPhases
    let foreignDeclType :: TypeQ
        foreignDeclType =
          fmap (wrapForall forallCxt) $
          arrowT `appT` (conT ''Foreign.FunPtr `appT` pure rawFuncType'') `appT` pure rawFuncType''
    foreignDecl <- forImpD cCall safety "dynamic" foreignFuncName foreignDeclType
    pure [typeSig, mainDecl, inlinePragma, foreignDecl]
    where
      name' = mkName name
  
  