-- |
-- 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 = Name -> Q Type
conT (String -> Name
mkName "SEXP0")

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

-- | 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 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]

-- | 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 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
        -- XXX: Ideally would import these names from their defining module, but
        -- see GHC bug #1012. Using 'mkName' is a workaround.
        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" |]) [] ]
      ]