-- |
-- 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 = conT (mkName "SEXP0")

-- | Generate wrappers from n to m.
thWrappers :: Int -> Int -> Q [Dec]
thWrappers n m = mapM thWrapper [n..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 n = do
    let vars = map (mkName . return) $ take (n + 1) ['a'..]
        ty = go (map varT vars)
    forImpD cCall safe "wrapper" (mkName $ "wrap" ++ show n) $
      [t| $ty -> IO (FunPtr $ty) |]
  where
    go :: [Q Type] -> Q Type
    go [] = impossible "thWrapper"
    go [_] = [t| IO $nSEXP0 |]
    go (_:xs) = [t| $nSEXP0 -> $(go xs) |]

thWrapperLiterals :: Int -> Int -> Q [Dec]
thWrapperLiterals n m = mapM thWrapperLiteral [n..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 n = do
    let s = varT =<< newName "s"
    names1 <- replicateM (n + 1) $ newName "a"
    names2 <- replicateM (n + 1) $ newName "i"
    let mkTy []     = impossible "thWrapperLiteral"
        mkTy [x]    = [t| $nR $s $x |]
        mkTy (x:xs) = [t| $x -> $(mkTy xs) |]
        ctx = cxt $
#if MIN_VERSION_template_haskell(2,10,0)
              [AppT (ConT (mkName "NFData")) <$> varT (last names1)] ++
#else
              [classP (mkName "NFData") [varT (last names1)]] ++
#endif
              zipWith f (map varT names1) (map varT names2)
          where
#if MIN_VERSION_template_haskell(2,10,0)
            f tv1 tv2 = foldl AppT (ConT (mkName "Literal")) <$> sequence [tv1, 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 = conT $ mkName "R"
        nwrapn = varE $ mkName $ "wrap" ++ show n
        nfunToSEXP = varE $ mkName "Language.R.Literal.funToSEXP"
        nLiteral = conT $ mkName "Literal"
    instanceD ctx [t| $nLiteral $(mkTy $ map varT names1) 'R.ExtPtr |]
      [ funD (mkName "mkSEXPIO")
          [ clause [] (normalB [| $nfunToSEXP $nwrapn |]) [] ]
      , funD (mkName "fromSEXP")
          [ clause [] (normalB [| unimplemented "thWrapperLiteral fromSEXP" |]) [] ]
      ]