{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
module LLVM.Core.Instructions.TypeAssisted (
    Assistant,
    scalar,
    vector,
    trunc,
    ext,
    extBool,
    zadapt,
    sadapt,
    adapt,
    fptrunc,
    fpext,
    fptoint,
    inttofp,
    ptrtoint,
    inttoptr,
    bitcast,
    select,
    ) where

import qualified LLVM.Core.Instructions.Private as Priv
import qualified LLVM.Util.Proxy as LP
import LLVM.Core.Instructions.Private (ValueCons)
import LLVM.Core.Data (Vector)
import LLVM.Core.Type
         (IsInteger, IsFloating, IsFirstClass, IsPrimitive,
          Signed, Positive, IsType, IsSized, SizeOf,
          isSigned, sizeOf, typeDesc)
import LLVM.Core.CodeGenMonad (CodeGenFunction)

import qualified LLVM.FFI.Core as FFI

import Type.Data.Num.Decimal.Number ((:<:), (:>:))

import Foreign.Ptr (Ptr)



data Assistant a b av bv = Assistant

scalar :: Assistant a b a b
scalar = Assistant

vector ::
    (Positive n, IsPrimitive a, IsPrimitive b) =>
    Assistant a b (Vector n a) (Vector n b)
vector = Assistant


-- | Truncate a value to a shorter bit width.
trunc ::
    (ValueCons value, IsInteger av, IsInteger bv,
     IsSized a, IsSized b, SizeOf a :>: SizeOf b) =>
    Assistant a b av bv -> value av -> CodeGenFunction r (value bv)
trunc = convert FFI.constTrunc FFI.buildTrunc

-- | Extend a value to wider width.
-- If the target type is signed, then preserve the sign,
-- If the target type is unsigned, then extended by zeros.
ext :: forall value a b av bv r.
    (ValueCons value, IsInteger av, IsInteger bv, Signed a ~ Signed b,
     IsSized a, IsSized b, SizeOf a :<: SizeOf b) =>
    Assistant a b av bv -> value av -> CodeGenFunction r (value bv)
ext =
   if isSigned (LP.Proxy :: LP.Proxy bv)
     then convert FFI.constSExt FFI.buildSExt
     else convert FFI.constZExt FFI.buildZExt

extBool :: forall value b av bv r.
    (ValueCons value, IsInteger bv) =>
    Assistant Bool b av bv -> value av -> CodeGenFunction r (value bv)
extBool =
   if isSigned (LP.Proxy :: LP.Proxy bv)
     then convert FFI.constSExt FFI.buildSExt
     else convert FFI.constZExt FFI.buildZExt


-- | It is 'zext', 'trunc' or nop depending on the relation of the sizes.
zadapt :: forall value a b av bv r.
    (ValueCons value, IsInteger av, IsInteger bv) =>
    Assistant a b av bv -> value av -> CodeGenFunction r (value bv)
zadapt =
   case compare (sizeOf (typeDesc (LP.Proxy :: LP.Proxy av)))
                (sizeOf (typeDesc (LP.Proxy :: LP.Proxy bv))) of
      LT -> convert FFI.constZExt FFI.buildZExt
      EQ -> convert FFI.constBitCast FFI.buildBitCast
      GT -> convert FFI.constTrunc FFI.buildTrunc

-- | It is 'sext', 'trunc' or nop depending on the relation of the sizes.
sadapt :: forall value a b av bv r.
    (ValueCons value, IsInteger av, IsInteger bv) =>
    Assistant a b av bv -> value av -> CodeGenFunction r (value bv)
sadapt =
   case compare (sizeOf (typeDesc (LP.Proxy :: LP.Proxy av)))
                (sizeOf (typeDesc (LP.Proxy :: LP.Proxy bv))) of
      LT -> convert FFI.constSExt FFI.buildSExt
      EQ -> convert FFI.constBitCast FFI.buildBitCast
      GT -> convert FFI.constTrunc FFI.buildTrunc

-- | It is 'sadapt' or 'zadapt' depending on the sign mode.
adapt :: forall value a b av bv r.
    (ValueCons value, IsInteger av, IsInteger bv, Signed a ~ Signed b) =>
    Assistant a b av bv -> value av -> CodeGenFunction r (value bv)
adapt =
   case compare (sizeOf (typeDesc (LP.Proxy :: LP.Proxy av)))
                (sizeOf (typeDesc (LP.Proxy :: LP.Proxy bv))) of
      LT ->
         if isSigned (LP.Proxy :: LP.Proxy bv)
           then convert FFI.constSExt FFI.buildSExt
           else convert FFI.constZExt FFI.buildZExt
      EQ -> convert FFI.constBitCast FFI.buildBitCast
      GT -> convert FFI.constTrunc FFI.buildTrunc

-- | Truncate a floating point value.
fptrunc ::
    (ValueCons value, IsFloating av, IsFloating bv,
     IsSized a, IsSized b, SizeOf a :>: SizeOf b) =>
    Assistant a b av bv -> value av -> CodeGenFunction r (value bv)
fptrunc = convert FFI.constFPTrunc FFI.buildFPTrunc

-- | Extend a floating point value.
fpext ::
    (ValueCons value, IsFloating av, IsFloating bv,
     IsSized a, IsSized b, SizeOf a :<: SizeOf b) =>
    Assistant a b av bv -> value av -> CodeGenFunction r (value bv)
fpext = convert FFI.constFPExt FFI.buildFPExt

-- | Convert a floating point value to an integer.
-- It is mapped to @fptosi@ or @fptoui@ depending on the type @a@.
fptoint :: forall value a b av bv r.
    (ValueCons value, IsFloating av, IsInteger bv) =>
    Assistant a b av bv -> value av -> CodeGenFunction r (value bv)
fptoint =
   if isSigned (LP.Proxy :: LP.Proxy bv)
     then convert FFI.constFPToSI FFI.buildFPToSI
     else convert FFI.constFPToUI FFI.buildFPToUI


-- | Convert an integer to a floating point value.
-- It is mapped to @sitofp@ or @uitofp@ depending on the type @a@.
inttofp :: forall value a b av bv r.
    (ValueCons value, IsInteger av, IsFloating bv) =>
    Assistant a b av bv -> value av -> CodeGenFunction r (value bv)
inttofp =
   if isSigned (LP.Proxy :: LP.Proxy av)
     then convert FFI.constSIToFP FFI.buildSIToFP
     else convert FFI.constUIToFP FFI.buildUIToFP


-- | Convert a pointer to an integer.
ptrtoint ::
    (ValueCons value, IsInteger bv) =>
    Assistant (Ptr a) b av bv -> value av -> CodeGenFunction r (value bv)
ptrtoint = convert FFI.constPtrToInt FFI.buildPtrToInt

-- | Convert an integer to a pointer.
inttoptr ::
    (ValueCons value, IsInteger av, IsType bv) =>
    Assistant a (Ptr b) av bv -> value av -> CodeGenFunction r (value bv)
inttoptr = convert FFI.constIntToPtr FFI.buildIntToPtr

-- | Convert between to values of the same size by just copying the bit pattern.
bitcast ::
    (ValueCons value, IsFirstClass a, IsFirstClass bv,
     IsSized a, IsSized b, SizeOf a ~ SizeOf b) =>
    Assistant a b av bv -> value av -> CodeGenFunction r (value bv)
bitcast = convert FFI.constBitCast FFI.buildBitCast


convert :: (ValueCons value, IsType bv) =>
    Priv.FFIConstConvert -> Priv.FFIConvert -> Assistant a b av bv ->
    value av -> CodeGenFunction r (value bv)
convert cnvConst cnv Assistant = Priv.convert cnvConst cnv



select ::
    (ValueCons value, IsFirstClass a) =>
    Assistant a Bool av bv ->
    value bv -> value av -> value av -> CodeGenFunction r (value av)
select Assistant = Priv.trinop FFI.constSelect FFI.buildSelect