{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
module LLVM.Core.Instructions.Private where

import qualified LLVM.Core.Util as U
import qualified LLVM.Util.Proxy as LP
import LLVM.Core.Type (IsType, typeRef)
import LLVM.Core.CodeGenMonad (CodeGenFunction)
import LLVM.Core.CodeGen
         (Value(Value), ConstValue(ConstValue), withCurrentBuilder)

import qualified LLVM.FFI.Core as FFI

import Control.Monad.IO.Class (liftIO)
import Control.Monad (liftM)



type FFIConstConvert = FFI.ValueRef -> FFI.TypeRef -> IO FFI.ValueRef

type FFIConvert =
        FFI.BuilderRef -> FFI.ValueRef -> FFI.TypeRef ->
        U.CString -> IO FFI.ValueRef

type FFIConstUnOp = FFI.ValueRef -> IO FFI.ValueRef
type FFIUnOp = FFI.BuilderRef -> FFI.ValueRef -> U.CString -> IO FFI.ValueRef

type FFIConstTrinOp =
        FFI.ValueRef -> FFI.ValueRef -> FFI.ValueRef -> IO FFI.ValueRef
type FFITrinOp =
        FFI.BuilderRef -> FFI.ValueRef -> FFI.ValueRef -> FFI.ValueRef ->
        U.CString -> IO FFI.ValueRef


class ValueCons value where
    convert :: (IsType b) =>
        FFIConstConvert -> FFIConvert -> value a -> CodeGenFunction r (value b)
    aunop ::
        FFIConstUnOp -> FFIUnOp -> value a -> CodeGenFunction r (value b)
    trinop ::
        FFIConstTrinOp -> FFITrinOp ->
        value a -> value b -> value c -> CodeGenFunction r (value d)


instance ValueCons ConstValue where
    convert cnv _ = convertConstValue cnv
    aunop cop _ (ConstValue a) = liftIO $ fmap ConstValue $ cop a
    trinop cop _ (ConstValue a) (ConstValue b) (ConstValue c) =
        liftIO $ fmap ConstValue $ cop a b c

convertConstValue ::
    forall a b r. (IsType b) =>
    FFIConstConvert -> ConstValue a -> CodeGenFunction r (ConstValue b)
convertConstValue conv (ConstValue a) =
    liftM ConstValue $ liftIO $
        conv a =<< typeRef (LP.Proxy :: LP.Proxy b)


instance ValueCons Value where
    convert _ cnv = convertValue cnv
    aunop _ op (Value a) =
        liftM Value $
        withCurrentBuilder $ \ bld ->
            U.withEmptyCString $ op bld a
    trinop _ op (Value a) (Value b) (Value c) =
        liftM Value $
        withCurrentBuilder $ \ bld ->
            U.withEmptyCString $ op bld a b c

convertValue ::
    forall a b r. (IsType b) =>
    FFIConvert -> Value a -> CodeGenFunction r (Value b)
convertValue conv (Value a) =
    liftM Value $
    withCurrentBuilder $ \ bldPtr -> do
      typ <- typeRef (LP.Proxy :: LP.Proxy b)
      U.withEmptyCString $ conv bldPtr a typ