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