----------------------------------------------------------------------------
-- |
-- 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 :: Type -> ([Type], Type)
decomposeFunctionType = [Type] -> Type -> ([Type], Type)
go []
  where
    go :: [Type] -> Type -> ([Type], Type)
    go :: [Type] -> Type -> ([Type], Type)
go [Type]
args = \case
      ForallT [TyVarBndr Specificity]
_ [Type]
_ Type
t          -> [Type] -> Type -> ([Type], Type)
go [Type]
args Type
t
      AppT (AppT Type
ArrowT Type
x) Type
y -> [Type] -> Type -> ([Type], Type)
go (Type
x Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
args) Type
y
      Type
ret                    -> ([Type] -> [Type]
forall a. [a] -> [a]
reverse [Type]
args, Type
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 :: Type -> (Maybe ([TyVarBndr Specificity], [Type]), Type)
unwrapForall (ForallT [TyVarBndr Specificity]
bs [Type]
c Type
t) = (([TyVarBndr Specificity], [Type])
-> Maybe ([TyVarBndr Specificity], [Type])
forall a. a -> Maybe a
Just ([TyVarBndr Specificity]
bs, [Type]
c), Type
t)
unwrapForall Type
t                = (Maybe ([TyVarBndr Specificity], [Type])
forall a. Maybe a
Nothing, Type
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 :: Maybe ([TyVarBndr Specificity], [Type]) -> Type -> Type
wrapForall Maybe ([TyVarBndr Specificity], [Type])
Nothing        = Type -> Type
forall a. a -> a
id
wrapForall (Just ([TyVarBndr Specificity]
bs, [Type]
c)) = [TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [TyVarBndr Specificity]
bs [Type]
c

wrapEmacsFunc :: String -> Safety -> ExpQ -> TypeQ -> DecsQ
wrapEmacsFunc :: String -> Safety -> ExpQ -> TypeQ -> DecsQ
wrapEmacsFunc String
name Safety
safety ExpQ
peekExpr TypeQ
rawFuncType = do
  Type
rawFuncType' <- TypeQ
rawFuncType
  let (Maybe ([TyVarBndr Specificity], [Type])
forallCxt, Type
rawFuncType'') = Type -> (Maybe ([TyVarBndr Specificity], [Type]), Type)
unwrapForall Type
rawFuncType'
      ([Type]
args, Type
ret)                = Type -> ([Type], Type)
decomposeFunctionType Type
rawFuncType''
  (Name
envArg, [Name]
otherArgs) <- case [Type]
args of
    [] -> String -> Q (Name, [Name])
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Name, [Name])) -> String -> Q (Name, [Name])
forall a b. (a -> b) -> a -> b
$
      String
"Raw function type must take at least one emacs_env argument: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
rawFuncType'
    Type
x : [Type]
xs
     | Type
x Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Type
ConT ''Env.Env -> String -> Q (Name, [Name])
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Name, [Name])) -> String -> Q (Name, [Name])
forall a b. (a -> b) -> a -> b
$
       String
"Raw function type must take emacs_env as a first argument, but takes " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
rawFuncType'
     | Bool
otherwise ->
        (,) (Name -> [Name] -> (Name, [Name]))
-> Q Name -> Q ([Name] -> (Name, [Name]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"env" Q ([Name] -> (Name, [Name])) -> Q [Name] -> Q (Name, [Name])
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type -> Q Name) -> [Type] -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Q Name -> Type -> Q Name
forall a b. a -> b -> a
const (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")) [Type]
xs
  Name
foreignFuncName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ String
"emacs_func_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
  let envPat :: PatQ
      envPat :: PatQ
envPat = Name -> PatQ
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
envArg
      pats :: [PatQ]
pats   = PatQ
envPat PatQ -> [PatQ] -> [PatQ]
forall a. a -> [a] -> [a]
: (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
otherArgs
      body :: Q Body
body   = ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (ExpQ -> Q Body) -> ExpQ -> Q Body
forall a b. (a -> b) -> a -> b
$ do
        Name
funPtrVar <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"funPtr"
        [e|liftIO|] ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` [Q Stmt] -> ExpQ
forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
doE
          [ PatQ -> ExpQ -> Q Stmt
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Stmt
bindS (Name -> PatQ
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
funPtrVar) (ExpQ -> Q Stmt) -> ExpQ -> Q Stmt
forall a b. (a -> b) -> a -> b
$ ExpQ
peekExpr ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ([e| Env.toPtr |] ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
envArg)
          , ExpQ -> Q Stmt
forall (m :: * -> *). Quote m => m Exp -> m Stmt
noBindS (ExpQ -> Q Stmt) -> ExpQ -> Q Stmt
forall a b. (a -> b) -> a -> b
$ (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
foreignFuncName) ((Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE ([Name] -> [ExpQ]) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> a -> b
$ Name
funPtrVar Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: Name
envArg Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
otherArgs)
          ]
  Name
m    <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"m"
  Type
ret' <- case Type
ret of
    AppT Type
monad Type
result
      | Type
monad Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
ConT ''IO
      -> TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
m) (Type -> TypeQ
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
result)
    Type
_ -> String -> TypeQ
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> TypeQ) -> String -> TypeQ
forall a b. (a -> b) -> a -> b
$ String
"Expected function that returns result in IO monad"
  let tv :: TyVarBndr Specificity
tv         = Name -> Specificity -> TyVarBndr Specificity
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
m Specificity
SpecifiedSpec
      constraint :: Type
constraint = Name -> Type
ConT ''MonadIO Type -> Type -> Type
`AppT` (Name -> Type
VarT Name
m)
  Dec
typeSig      <- Name -> TypeQ -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
name' (TypeQ -> Q Dec) -> TypeQ -> Q Dec
forall a b. (a -> b) -> a -> b
$ Type -> TypeQ
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> TypeQ) -> Type -> TypeQ
forall a b. (a -> b) -> a -> b
$
    Maybe ([TyVarBndr Specificity], [Type]) -> Type -> Type
wrapForall (([TyVarBndr Specificity], [Type])
-> Maybe ([TyVarBndr Specificity], [Type])
forall a. a -> Maybe a
Just (([TyVarBndr Specificity], [Type])
-> (([TyVarBndr Specificity], [Type])
    -> ([TyVarBndr Specificity], [Type]))
-> Maybe ([TyVarBndr Specificity], [Type])
-> ([TyVarBndr Specificity], [Type])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([TyVarBndr Specificity
tv], [Type
constraint]) (([TyVarBndr Specificity] -> [TyVarBndr Specificity])
-> ([Type] -> [Type])
-> ([TyVarBndr Specificity], [Type])
-> ([TyVarBndr Specificity], [Type])
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (TyVarBndr Specificity
tv :) (Type
constraint :)) Maybe ([TyVarBndr Specificity], [Type])
forallCxt)) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
      (Type -> Type -> Type) -> Type -> [Type] -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Type
x Type
acc -> Type
ArrowT Type -> Type -> Type
`AppT` Type
x Type -> Type -> Type
`AppT` Type
acc) Type
ret' [Type]
args
  Dec
mainDecl     <- Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
name' [[PatQ] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [PatQ]
pats Q Body
body []]
  Dec
inlinePragma <- Name -> Inline -> RuleMatch -> Phases -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD Name
name' Inline
Inline RuleMatch
FunLike Phases
AllPhases
  let foreignDeclType :: TypeQ
      foreignDeclType :: TypeQ
foreignDeclType =
        (Type -> Type) -> TypeQ -> TypeQ
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe ([TyVarBndr Specificity], [Type]) -> Type -> Type
wrapForall Maybe ([TyVarBndr Specificity], [Type])
forallCxt) (TypeQ -> TypeQ) -> TypeQ -> TypeQ
forall a b. (a -> b) -> a -> b
$
        TypeQ
forall (m :: * -> *). Quote m => m Type
arrowT TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` (Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Foreign.FunPtr TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Type -> TypeQ
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
rawFuncType'') TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Type -> TypeQ
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
rawFuncType''
  Dec
foreignDecl <- Callconv -> Safety -> String -> Name -> TypeQ -> Q Dec
forall (m :: * -> *).
Quote m =>
Callconv -> Safety -> String -> Name -> m Type -> m Dec
forImpD Callconv
cCall Safety
safety String
"dynamic" Name
foreignFuncName TypeQ
foreignDeclType
  [Dec] -> DecsQ
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
typeSig, Dec
mainDecl, Dec
inlinePragma, Dec
foreignDecl]
  where
    name' :: Name
name' = String -> Name
mkName String
name