-- |
-- Copyright: (C) 2013 Amgen, Inc.

{-# 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

-- XXX: If we build quotes that mention names imported from Foreign.R, then
-- GHC panics because it fails to link in all adequate object files to
-- resolve all R symbols. So instead we build the symbol names
-- programmatically, using mkName...
nSEXP0 :: Q Type
nSEXP0 :: Q Type
nSEXP0 = forall (m :: * -> *). Quote m => Name -> m Type
conT (String -> Name
mkName String
"SEXP0")

-- | Generate wrappers from n to m.
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]

-- | Generate wrapper.
--
-- Example for input 5:
--
-- @
-- foreign import ccall \"wrapper\" wrap5
--    :: (  SEXP a -> SEXP b -> SEXP c
--       -> SEXP d -> SEXP e -> IO (SEXP f)
--       )
--    -> IO (FunPtr (  SEXP a -> SEXP b -> SEXP c
--                  -> SEXP d -> SEXP e -> IO (SEXP f)
--                  )
--          )
-- @
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]

-- | Generate Literal Instance for wrapper.
--
-- Example for input 6:
-- @
-- instance ( Literal a a0, Literal b b0, Literal c c0, Literal d d0, Literal e e0
--         , Literal f f0, Literal g g0
--         )
--         => Literal (a -> b -> c -> d -> e -> f -> IO g) R.ExtPtr where
--    mkSEXP = funToSEXP wrap6
--    fromSEXP = error \"Unimplemented.\"
-- @
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
        -- XXX: Ideally would import these names from their defining module, but
        -- see GHC bug #1012. Using 'mkName' is a workaround.
        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" |]) [] ]
      ]