{-# LANGUAGE
  TemplateHaskell
  #-}
module LLVM.Internal.FFI.Cleanup where

import LLVM.Prelude

import Language.Haskell.TH
import Data.Sequence as Seq

import Foreign.C
import Foreign.Ptr

import LLVM.Internal.FFI.LLVMCTypes
import qualified LLVM.Internal.FFI.PtrHierarchy as FFI

import qualified LLVM.AST.IntegerPredicate as A (IntegerPredicate) 
import qualified LLVM.AST.FloatingPointPredicate as A (FloatingPointPredicate) 
import qualified LLVM.AST.Constant as A.C (Constant)
import qualified LLVM.AST.Operand as A (Operand)
import qualified LLVM.AST.Type as A (Type)
import qualified LLVM.AST.Instruction as A (FastMathFlags)

foreignDecl :: String -> String -> [TypeQ] -> TypeQ -> DecsQ
foreignDecl :: String -> String -> [TypeQ] -> TypeQ -> DecsQ
foreignDecl String
cName String
hName [TypeQ]
argTypeQs TypeQ
returnTypeQ = do
  let retTyQ :: TypeQ
retTyQ = TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
conT ''IO) TypeQ
returnTypeQ
      foreignDecl' :: String -> t TypeQ -> Q Dec
foreignDecl' String
hName t TypeQ
argTypeQs =
        Callconv -> Safety -> String -> Name -> TypeQ -> Q Dec
forall (m :: * -> *).
Quote m =>
Callconv -> Safety -> String -> Name -> m Type -> m Dec
forImpD Callconv
cCall Safety
unsafe String
cName (String -> Name
mkName String
hName) 
                  ((TypeQ -> TypeQ -> TypeQ) -> TypeQ -> t TypeQ -> TypeQ
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\TypeQ
a TypeQ
b -> TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT TypeQ
forall (m :: * -> *). Quote m => m Type
arrowT TypeQ
a) TypeQ
b) TypeQ
retTyQ t TypeQ
argTypeQs)
      splitTuples :: [Type] -> Q ([Type], [Pat], [Exp])
      splitTuples :: [Type] -> Q ([Type], [Pat], [Exp])
splitTuples [Type]
ts = do
        let f :: Type -> Q (Seq Type, Pat, Seq Exp)
            f :: Type -> Q (Seq Type, Pat, Seq Exp)
f x :: Type
x@(AppT Type
_ Type
_) = Q (Seq Type, Pat, Seq Exp)
-> (Q (Seq Type, Seq Pat, Seq Exp) -> Q (Seq Type, Pat, Seq Exp))
-> Maybe (Q (Seq Type, Seq Pat, Seq Exp))
-> Q (Seq Type, Pat, Seq Exp)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Type -> Q (Seq Type, Pat, Seq Exp)
d Type
x) (\Q (Seq Type, Seq Pat, Seq Exp)
q -> Q (Seq Type, Seq Pat, Seq Exp)
q Q (Seq Type, Seq Pat, Seq Exp)
-> ((Seq Type, Seq Pat, Seq Exp) -> Q (Seq Type, Pat, Seq Exp))
-> Q (Seq Type, Pat, Seq Exp)
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Seq Type
ts, Seq Pat
ps, Seq Exp
es) -> (Seq Type, Pat, Seq Exp) -> Q (Seq Type, Pat, Seq Exp)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Seq Type
ts, [Pat] -> Pat
TupP (Seq Pat -> [Pat]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Pat
ps), Seq Exp
es)) (Int -> Type -> Maybe (Q (Seq Type, Seq Pat, Seq Exp))
g Int
0 Type
x)
            f Type
x = Type -> Q (Seq Type, Pat, Seq Exp)
d Type
x
            g :: Int -> Type -> Maybe (Q (Seq Type, Seq Pat, Seq Exp))
            g :: Int -> Type -> Maybe (Q (Seq Type, Seq Pat, Seq Exp))
g Int
n (TupleT Int
m) | Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n = Q (Seq Type, Seq Pat, Seq Exp)
-> Maybe (Q (Seq Type, Seq Pat, Seq Exp))
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Seq Type, Seq Pat, Seq Exp) -> Q (Seq Type, Seq Pat, Seq Exp)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Seq Type
forall a. Seq a
Seq.empty, Seq Pat
forall a. Seq a
Seq.empty, Seq Exp
forall a. Seq a
Seq.empty))
            g Int
n (AppT Type
a Type
b) = do
              Q (Seq Type, Seq Pat, Seq Exp)
k <- Int -> Type -> Maybe (Q (Seq Type, Seq Pat, Seq Exp))
g (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Type
a
              Q (Seq Type, Seq Pat, Seq Exp)
-> Maybe (Q (Seq Type, Seq Pat, Seq Exp))
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Q (Seq Type, Seq Pat, Seq Exp)
 -> Maybe (Q (Seq Type, Seq Pat, Seq Exp)))
-> Q (Seq Type, Seq Pat, Seq Exp)
-> Maybe (Q (Seq Type, Seq Pat, Seq Exp))
forall a b. (a -> b) -> a -> b
$ do
                (Seq Type
ts, Seq Pat
ps, Seq Exp
es) <- Q (Seq Type, Seq Pat, Seq Exp)
k
                (Seq Type
ts', Pat
p', Seq Exp
es') <- Type -> Q (Seq Type, Pat, Seq Exp)
f Type
b
                (Seq Type, Seq Pat, Seq Exp) -> Q (Seq Type, Seq Pat, Seq Exp)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Seq Type
ts Seq Type -> Seq Type -> Seq Type
forall a. Seq a -> Seq a -> Seq a
>< Seq Type
ts', Seq Pat
ps Seq Pat -> Pat -> Seq Pat
forall a. Seq a -> a -> Seq a
|> Pat
p', Seq Exp
es Seq Exp -> Seq Exp -> Seq Exp
forall a. Seq a -> Seq a -> Seq a
>< Seq Exp
es')
            g Int
_ Type
_ = Maybe (Q (Seq Type, Seq Pat, Seq Exp))
forall a. Maybe a
Nothing
            d :: Type -> Q (Seq Type, Pat, Seq Exp)
            d :: Type -> Q (Seq Type, Pat, Seq Exp)
d Type
x = do
              Name
n <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"v"
              (Seq Type, Pat, Seq Exp) -> Q (Seq Type, Pat, Seq Exp)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Seq Type
forall a. a -> Seq a
Seq.singleton Type
x, Name -> Pat
VarP Name
n, Exp -> Seq Exp
forall a. a -> Seq a
Seq.singleton (Name -> Exp
VarE Name
n))
            seqsToList :: [Seq a] -> [a]
            seqsToList :: forall a. [Seq a] -> [a]
seqsToList = Seq a -> [a]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq a -> [a]) -> ([Seq a] -> Seq a) -> [Seq a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Seq a -> Seq a -> Seq a) -> Seq a -> [Seq a] -> Seq a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Seq a -> Seq a -> Seq a
forall a. Seq a -> Seq a -> Seq a
(><) Seq a
forall a. Seq a
Seq.empty
                
        ([Seq Type]
tss, [Pat]
ps, [Seq Exp]
ess) <- ([(Seq Type, Pat, Seq Exp)] -> ([Seq Type], [Pat], [Seq Exp]))
-> Q [(Seq Type, Pat, Seq Exp)] -> Q ([Seq Type], [Pat], [Seq Exp])
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [(Seq Type, Pat, Seq Exp)] -> ([Seq Type], [Pat], [Seq Exp])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 (Q [(Seq Type, Pat, Seq Exp)] -> Q ([Seq Type], [Pat], [Seq Exp]))
-> ([Type] -> Q [(Seq Type, Pat, Seq Exp)])
-> [Type]
-> Q ([Seq Type], [Pat], [Seq Exp])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Q (Seq Type, Pat, Seq Exp))
-> [Type] -> Q [(Seq Type, Pat, Seq Exp)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> Q (Seq Type, Pat, Seq Exp)
f ([Type] -> Q ([Seq Type], [Pat], [Seq Exp]))
-> [Type] -> Q ([Seq Type], [Pat], [Seq Exp])
forall a b. (a -> b) -> a -> b
$ [Type]
ts
        ([Type], [Pat], [Exp]) -> Q ([Type], [Pat], [Exp])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Seq Type] -> [Type]
forall a. [Seq a] -> [a]
seqsToList [Seq Type]
tss, [Pat]
ps, [Seq Exp] -> [Exp]
forall a. [Seq a] -> [a]
seqsToList [Seq Exp]
ess)

                                
  [Type]
argTypes <- [TypeQ] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [TypeQ]
argTypeQs
  ([Type]
ts, [Pat]
ps, [Exp]
es) <- [Type] -> Q ([Type], [Pat], [Exp])
splitTuples [Type]
argTypes
  let phName :: String
phName = String
hName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
  [Q Dec] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [
    String -> [TypeQ] -> Q Dec
forall {t :: * -> *}. Foldable t => String -> t TypeQ -> Q Dec
foreignDecl' String
phName ((Type -> TypeQ) -> [Type] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TypeQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Type]
ts),
    Name -> TypeQ -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD (String -> Name
mkName String
hName) ((TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\TypeQ
argT TypeQ
retT -> TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT TypeQ
forall (m :: * -> *). Quote m => m Type
arrowT TypeQ
argT) TypeQ
retT) TypeQ
retTyQ [TypeQ]
argTypeQs),
    Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (String -> Name
mkName String
hName) [
     [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause ((Pat -> Q Pat) -> [Pat] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Pat -> Q Pat
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Pat]
ps) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB ((Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
phName)) ((Exp -> Q Exp) -> [Exp] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Exp]
es))) []
    ]
   ]

-- | The LLVM C-API for instructions with boolean flags (e.g. nsw) and is weak, so they get
-- separated out for different handling. This check is an accurate but crude test for whether
-- an instruction needs such handling.
hasFlags :: [Type] -> Bool
hasFlags :: [Type] -> Bool
hasFlags = (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
ConT ''Bool)

typeMapping :: Type -> TypeQ
typeMapping :: Type -> TypeQ
typeMapping Type
t = case Type
t of
  ConT Name
h | Name
h Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Bool -> [t| LLVMBool |]
         | Name
h Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Int32 -> [t| CInt |]
         | Name
h Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Word32 -> [t| CUInt |]
         | Name
h Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''String -> [t| CString |]
         | Name
h Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''A.Operand -> [t| Ptr FFI.Value |]
         | Name
h Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''A.Type -> [t| Ptr FFI.Type |]
         | Name
h Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''A.C.Constant -> [t| Ptr FFI.Constant |]
         | Name
h Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''A.FloatingPointPredicate -> [t| FCmpPredicate |]
         | Name
h Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''A.IntegerPredicate -> [t| ICmpPredicate |]
         | Name
h Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''A.FastMathFlags -> [t| FastMathFlags |]
  AppT Type
ListT Type
x -> (TypeQ -> TypeQ -> TypeQ) -> [TypeQ] -> TypeQ
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT [Int -> TypeQ
forall (m :: * -> *). Quote m => Int -> m Type
tupleT Int
2, [t| CUInt |], TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT [t| Ptr |] (Type -> TypeQ
typeMapping Type
x)]
  Type
x -> String -> TypeQ
forall a. HasCallStack => String -> a
error (String -> TypeQ) -> String -> TypeQ
forall a b. (a -> b) -> a -> b
$ String
"type not handled in Cleanup typeMapping: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
x