{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module LLVM.Util.MemoryComplete (
    memcpy,
    ) where

import qualified LLVM.FFI.Core as FFI

import Foreign.Ptr (FunPtr, nullPtr)

import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad (void)

import Data.Kind (Type)



newtype Value a = Value FFI.ValueRef

type Function a = Value (FunPtr a)


newtype CodeGenFunction (r :: Type) a = CGF (IO a)
    deriving (Functor, Applicative, Monad, MonadIO)


newFunction :: IO (Function a)
newFunction = do
    typ <- FFI.integerType 64
    fmap Value $ FFI.constInt typ 42 FFI.false


type family UnValue a
type instance UnValue (Value a) = a

type family CodeResult code
type instance CodeResult (CodeGenFunction r a) = r
type instance CodeResult (a -> b) = CodeResult b


-- |Acceptable arguments to 'call'.
class (f ~ CalledFunction g, r ~ CodeResult g, g ~ CallerFunction r f) =>
         CallArgs r f g where
    type CalledFunction g
    type CallerFunction r f
    doCall :: Call f -> g

instance (Value a ~ a', CallArgs r b b') => CallArgs r (a -> b) (a' -> b') where
    type CalledFunction (a' -> b') = UnValue a' -> CalledFunction b'
    type CallerFunction r (a -> b) = Value a -> CallerFunction r b
    doCall f a = doCall (applyCall f a)

instance
    (Value a ~ a', r ~ r') =>
        CallArgs r (IO a) (CodeGenFunction r' a') where
    type CalledFunction (CodeGenFunction r' a') = IO (UnValue a')
    type CallerFunction r (IO a) = CodeGenFunction r (Value a)
    doCall = runCall

newtype Call a = Call (FFI.BuilderRef -> IO FFI.ValueRef)

applyCall :: Call (a -> b) -> Value a -> Call b
applyCall (Call mkCall) (Value _arg) = Call mkCall

runCall :: Call (IO a) -> CodeGenFunction r (Value a)
runCall (Call mkCall) = liftIO $ fmap Value $ mkCall nullPtr

-- | Call a function with the given arguments.  The 'call' instruction is variadic, i.e., the number of arguments
-- it takes depends on the type of /f/.
call :: (CallArgs r f g) => Function f -> g
call (Value f) =
   doCall $ Call (\bldPtr -> FFI.buildCall bldPtr f nullPtr 0 nullPtr)



memcpy ::
   IO
      (Value Bool ->
       Value Bool ->
       Value Bool ->
       Value Bool ->
       Value Bool ->
       CodeGenFunction r ())
memcpy =
   fmap
      (\f dest src len align volatile ->
          void $
             call
                (f :: Function (Bool -> Bool -> Bool -> Bool -> Bool -> IO ()))
                dest src len align volatile)
      newFunction