----------------------------------------------------------------------------
-- |
-- 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 LambdaCase            #-}
{-# LANGUAGE TemplateHaskellQuotes #-}

module Data.Emacs.Module.Raw.Env.TH (wrapEmacsFunc, Safety(..)) where

import Control.Monad.IO.Class
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]
_ [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], [Type]), Type)
unwrapForall (ForallT [TyVarBndr]
bs [Type]
c Type
t) = (([TyVarBndr], [Type]) -> Maybe ([TyVarBndr], [Type])
forall a. a -> Maybe a
Just ([TyVarBndr]
bs, [Type]
c), Type
t)
unwrapForall Type
t                = (Maybe ([TyVarBndr], [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], [Type]) -> Type -> Type
wrapForall Maybe ([TyVarBndr], [Type])
Nothing        = Type -> Type
forall a. a -> a
id
wrapForall (Just ([TyVarBndr]
bs, [Type]
c)) = [TyVarBndr] -> [Type] -> Type -> Type
ForallT [TyVarBndr]
bs [Type]
c

--   AppT (AppT ArrowT x) ret -> go [] ret x
--   invalid                  -> fail $ "Invalid function type: " ++ show invalid
--   where
--     go :: [Type] -> Type -> Type -> Q ([Type], Type)
--     go args ret = \case
--       AppT ArrowT firstArg -> pure (firstArg : args, ret)
--       AppT x      y        -> go (y : args) ret x
--       invalid              -> fail $ "Invalid function type: " ++ show invalid

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], [Type])
forallCxt, Type
rawFuncType'') = Type -> (Maybe ([TyVarBndr], [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 (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 (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
newName String
"env" Q ([Name] -> (Name, [Name])) -> Q [Name] -> Q (Name, [Name])
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)
traverse (Q Name -> Type -> Q Name
forall a b. a -> b -> a
const (String -> Q Name
newName String
"x")) [Type]
xs
  Name
foreignFuncName <- String -> Q 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
  -- fail $ "otherArgs = " ++ show otherArgs ++ ", rawFuncType = " ++ show rawFuncType'
  let envPat :: PatQ
envPat = Name -> PatQ
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
varP [Name]
otherArgs
      body :: BodyQ
body = ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ do
        Name
funPtrVar <- String -> Q Name
newName String
"funPtr"
        [e|liftIO|] ExpQ -> ExpQ -> ExpQ
`appE` [StmtQ] -> ExpQ
doE
          [ PatQ -> ExpQ -> StmtQ
bindS (Name -> PatQ
varP Name
funPtrVar) (ExpQ -> StmtQ) -> ExpQ -> StmtQ
forall a b. (a -> b) -> a -> b
$ ExpQ
peekExpr ExpQ -> ExpQ -> ExpQ
`appE` ([e| Env.toPtr |] ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE Name
envArg)
          , ExpQ -> StmtQ
noBindS (ExpQ -> StmtQ) -> ExpQ -> StmtQ
forall a b. (a -> b) -> a -> b
$ (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE Name
foreignFuncName) ((Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
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)
          ]
  Dec
mainDecl     <- Name -> [ClauseQ] -> DecQ
funD Name
name' [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [PatQ]
pats BodyQ
body []]
  Dec
inlinePragma <- Name -> Inline -> RuleMatch -> Phases -> DecQ
pragInlD Name
name' Inline
Inline RuleMatch
FunLike Phases
AllPhases
  let foreignDeclType :: TypeQ
foreignDeclType =
        (Type -> Type) -> TypeQ -> TypeQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe ([TyVarBndr], [Type]) -> Type -> Type
wrapForall Maybe ([TyVarBndr], [Type])
forallCxt) (TypeQ -> TypeQ) -> TypeQ -> TypeQ
forall a b. (a -> b) -> a -> b
$
        TypeQ
arrowT TypeQ -> TypeQ -> TypeQ
`appT` (Name -> TypeQ
conT ''Foreign.FunPtr TypeQ -> TypeQ -> TypeQ
`appT` Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
rawFuncType'') TypeQ -> TypeQ -> TypeQ
`appT` Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
rawFuncType''
  Dec
foreignDecl <- Callconv -> Safety -> String -> Name -> TypeQ -> DecQ
forImpD Callconv
cCall Safety
safety String
"dynamic" Name
foreignFuncName TypeQ
foreignDeclType
  [Dec] -> DecsQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
mainDecl, Dec
inlinePragma, Dec
foreignDecl]
  where
    name' :: Name
name' = String -> Name
mkName String
name