{-# 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 cName hName argTypeQs returnTypeQ = do
  let retTyQ = appT (conT ''IO) returnTypeQ
      foreignDecl' hName argTypeQs =
        forImpD cCall unsafe cName (mkName hName)
                  (foldr (\a b -> appT (appT arrowT a) b) retTyQ argTypeQs)
      splitTuples :: [Type] -> Q ([Type], [Pat], [Exp])
      splitTuples ts = do
        let f :: Type -> Q (Seq Type, Pat, Seq Exp)
            f x@(AppT _ _) = maybe (d x) (\q -> q >>= \(ts, ps, es) -> return (ts, TupP (toList ps), es)) (g 0 x)
            f x = d x
            g :: Int -> Type -> Maybe (Q (Seq Type, Seq Pat, Seq Exp))
            g n (TupleT m) | m == n = return (return (Seq.empty, Seq.empty, Seq.empty))
            g n (AppT a b) = do
              k <- g (n+1) a
              return $ do
                (ts, ps, es) <- k
                (ts', p', es') <- f b
                return (ts >< ts', ps |> p', es >< es')
            g _ _ = Nothing
            d :: Type -> Q (Seq Type, Pat, Seq Exp)
            d x = do
              n <- newName "v"
              return (Seq.singleton x, VarP n, Seq.singleton (VarE n))
            seqsToList :: [Seq a] -> [a]
            seqsToList = toList . foldr (><) Seq.empty

        (tss, ps, ess) <- liftM unzip3 . mapM f $ ts
        return (seqsToList tss, ps, seqsToList ess)


  argTypes <- sequence argTypeQs
  (ts, ps, es) <- splitTuples argTypes
  let phName = hName ++ "'"
  sequence [
    foreignDecl' phName (map return ts),
    sigD (mkName hName) (foldr (\argT retT -> appT (appT arrowT argT) retT) retTyQ argTypeQs),
    funD (mkName hName) [
     clause (map return ps) (normalB (foldl appE (varE (mkName phName)) (map return 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 = any (== ConT ''Bool)

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