{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}
module Language.R.Internal.FunWrappers.TH
( thWrappers
, thWrapper
, thWrapperLiteral
, thWrapperLiterals
) where
import Internal.Error
import qualified Foreign.R.Type as R
import Control.Monad (replicateM)
import Foreign (FunPtr)
import Language.Haskell.TH
nSEXP0 :: Q Type
nSEXP0 :: Q Type
nSEXP0 = forall (m :: * -> *). Quote m => Name -> m Type
conT (String -> Name
mkName String
"SEXP0")
thWrappers :: Int -> Int -> Q [Dec]
thWrappers :: Int -> Int -> Q [Dec]
thWrappers Int
n Int
m = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Int -> Q Dec
thWrapper [Int
n..Int
m]
thWrapper :: Int -> Q Dec
thWrapper :: Int -> Q Dec
thWrapper Int
n = do
let vars :: [Name]
vars = forall a b. (a -> b) -> [a] -> [b]
map (String -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return) forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take (Int
n forall a. Num a => a -> a -> a
+ Int
1) [Char
'a'..]
ty :: Q Type
ty = [Q Type] -> Q Type
go (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Type
varT [Name]
vars)
forall (m :: * -> *).
Quote m =>
Callconv -> Safety -> String -> Name -> m Type -> m Dec
forImpD Callconv
cCall Safety
safe String
"wrapper" (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"wrap" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n) forall a b. (a -> b) -> a -> b
$
[t| $ty -> IO (FunPtr $ty) |]
where
go :: [Q Type] -> Q Type
go :: [Q Type] -> Q Type
go [] = forall a. String -> a
impossible String
"thWrapper"
go [Q Type
_] = [t| IO $nSEXP0 |]
go (Q Type
_:[Q Type]
xs) = [t| $nSEXP0 -> $(go xs) |]
thWrapperLiterals :: Int -> Int -> Q [Dec]
thWrapperLiterals :: Int -> Int -> Q [Dec]
thWrapperLiterals Int
n Int
m = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Int -> Q Dec
thWrapperLiteral [Int
n..Int
m]
thWrapperLiteral :: Int -> Q Dec
thWrapperLiteral :: Int -> Q Dec
thWrapperLiteral Int
n = do
let s :: Q Type
s = forall (m :: * -> *). Quote m => Name -> m Type
varT forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). Quote m => String -> m Name
newName String
"s"
[Name]
names1 <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Int
n forall a. Num a => a -> a -> a
+ Int
1) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
[Name]
names2 <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Int
n forall a. Num a => a -> a -> a
+ Int
1) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => String -> m Name
newName String
"i"
let mkTy :: [Q Type] -> Q Type
mkTy [] = forall a. String -> a
impossible String
"thWrapperLiteral"
mkTy [Q Type
x] = [t| $nR $s $x |]
mkTy (Q Type
x:[Q Type]
xs) = [t| $x -> $(mkTy xs) |]
ctx :: Q Cxt
ctx = forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt forall a b. (a -> b) -> a -> b
$
#if MIN_VERSION_template_haskell(2,10,0)
[Type -> Type -> Type
AppT (Name -> Type
ConT (String -> Name
mkName String
"NFData")) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => Name -> m Type
varT (forall a. [a] -> a
last [Name]
names1)] forall a. [a] -> [a] -> [a]
++
#else
[classP (mkName "NFData") [varT (last names1)]] ++
#endif
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {f :: * -> *}. Monad f => f Type -> f Type -> f Type
f (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Type
varT [Name]
names1) (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Type
varT [Name]
names2)
where
#if MIN_VERSION_template_haskell(2,10,0)
f :: f Type -> f Type -> f Type
f f Type
tv1 f Type
tv2 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (String -> Name
mkName String
"Literal")) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [f Type
tv1, f Type
tv2]
#else
f tv1 tv2 = classP (mkName "Literal") [tv1, tv2]
#endif
nR :: Q Type
nR = forall (m :: * -> *). Quote m => Name -> m Type
conT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"R"
nwrapn :: Q Exp
nwrapn = forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"wrap" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n
nfunToSEXP :: Q Exp
nfunToSEXP = forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Language.R.Literal.funToSEXP"
nLiteral :: Q Type
nLiteral = forall (m :: * -> *). Quote m => Name -> m Type
conT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Literal"
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD Q Cxt
ctx [t| $nLiteral $(mkTy $ map varT names1) 'R.ExtPtr |]
[ forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (String -> Name
mkName String
"mkSEXPIO")
[ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| $nfunToSEXP $nwrapn |]) [] ]
, forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (String -> Name
mkName String
"fromSEXP")
[ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| unimplemented "thWrapperLiteral fromSEXP" |]) [] ]
]