{-# 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 = Name -> Q Type
conT (String -> Name
mkName "SEXP0")
thWrappers :: Int -> Int -> Q [Dec]
thWrappers :: Int -> Int -> Q [Dec]
thWrappers n :: Int
n m :: Int
m = (Int -> Q Dec) -> [Int] -> Q [Dec]
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 n :: Int
n = do
let vars :: [Name]
vars = (Char -> Name) -> String -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Name
mkName (String -> Name) -> (Char -> String) -> Char -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String
forall (m :: * -> *) a. Monad m => a -> m a
return) (String -> [Name]) -> String -> [Name]
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
take (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) ['a'..]
ty :: Q Type
ty = [Q Type] -> Q Type
go ((Name -> Q Type) -> [Name] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Type
varT [Name]
vars)
Callconv -> Safety -> String -> Name -> Q Type -> Q Dec
forImpD Callconv
cCall Safety
safe "wrapper" (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ "wrap" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n) (Q Type -> Q Dec) -> Q Type -> Q Dec
forall a b. (a -> b) -> a -> b
$
[t| $ty -> IO (FunPtr $ty) |]
where
go :: [Q Type] -> Q Type
go :: [Q Type] -> Q Type
go [] = String -> Q Type
forall a. String -> a
impossible "thWrapper"
go [_] = [t| IO $nSEXP0 |]
go (_:xs :: [Q Type]
xs) = [t| $nSEXP0 -> $(go xs) |]
thWrapperLiterals :: Int -> Int -> Q [Dec]
thWrapperLiterals :: Int -> Int -> Q [Dec]
thWrapperLiterals n :: Int
n m :: Int
m = (Int -> Q Dec) -> [Int] -> Q [Dec]
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 n :: Int
n = do
let s :: Q Type
s = Name -> Q Type
varT (Name -> Q Type) -> Q Name -> Q Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Q Name
newName "s"
[Name]
names1 <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (Q Name -> Q [Name]) -> Q Name -> Q [Name]
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName "a"
[Name]
names2 <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (Q Name -> Q [Name]) -> Q Name -> Q [Name]
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName "i"
let mkTy :: [Q Type] -> Q Type
mkTy [] = String -> Q Type
forall a. String -> a
impossible "thWrapperLiteral"
mkTy [x :: Q Type
x] = [t| $nR $s $x |]
mkTy (x :: Q Type
x:xs :: [Q Type]
xs) = [t| $x -> $(mkTy xs) |]
ctx :: CxtQ
ctx = [Q Type] -> CxtQ
cxt ([Q Type] -> CxtQ) -> [Q Type] -> CxtQ
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 "NFData")) (Type -> Type) -> Q Type -> Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q Type
varT ([Name] -> Name
forall a. [a] -> a
last [Name]
names1)] [Q Type] -> [Q Type] -> [Q Type]
forall a. [a] -> [a] -> [a]
++
#else
[classP (mkName "NFData") [varT (last names1)]] ++
#endif
(Q Type -> Q Type -> Q Type) -> [Q Type] -> [Q Type] -> [Q Type]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Q Type -> Q Type -> Q Type
forall (f :: * -> *). Monad f => f Type -> f Type -> f Type
f ((Name -> Q Type) -> [Name] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Type
varT [Name]
names1) ((Name -> Q Type) -> [Name] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Type
varT [Name]
names2)
where
#if MIN_VERSION_template_haskell(2,10,0)
f :: f Type -> f Type -> f Type
f tv1 :: f Type
tv1 tv2 :: f Type
tv2 = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT (String -> Name
mkName "Literal")) ([Type] -> Type) -> f [Type] -> f Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [f Type] -> f [Type]
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 = Name -> Q Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName "R"
nwrapn :: ExpQ
nwrapn = Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ "wrap" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
nfunToSEXP :: ExpQ
nfunToSEXP = Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName "Language.R.Literal.funToSEXP"
nLiteral :: Q Type
nLiteral = Name -> Q Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName "Literal"
CxtQ -> Q Type -> [Q Dec] -> Q Dec
instanceD CxtQ
ctx [t| $nLiteral $(mkTy $ map varT names1) 'R.ExtPtr |]
[ Name -> [ClauseQ] -> Q Dec
funD (String -> Name
mkName "mkSEXPIO")
[ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [| $nfunToSEXP $nwrapn |]) [] ]
, Name -> [ClauseQ] -> Q Dec
funD (String -> Name
mkName "fromSEXP")
[ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [| unimplemented "thWrapperLiteral fromSEXP" |]) [] ]
]