{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE ForeignFunctionInterface #-}

module Descriptors
    ( LLVMType
    , getFieldTypePtr
    , getMethodTypePtr
    , parseOnlyFieldType
    , parseOnlyMethodType
    ) where

import Data.ByteString (ByteString, pack, useAsCString, append)
import Data.Char (ord)
import Data.Attoparsec.ByteString
import Data.Maybe
import Foreign
import Foreign.C.Types
import Foreign.C.String

type U1 = Word8
type BString = Data.ByteString.ByteString

data FieldType = Base BaseType | Ref RefType
    deriving (Show, Eq)

data MethodType = MethodType [FieldType] RetType
    deriving (Show, Eq)

data BaseType = Byte
    | Char
    | Double
    | Float
    | Int
    | Long
    | Short
    | Boolean
    deriving (Show, Eq)

data RefType = Object BString | Array FieldType
    deriving (Show, Eq)

data RetType = Void | Field FieldType
    deriving (Show, Eq)


data LLVMType -- llvm type object

foreign import ccall safe "bridge.h getCharType"
    c_getCharType :: IO (Ptr LLVMType)

foreign import ccall safe "bridge.h getByteType"
    c_getByteType :: IO (Ptr LLVMType)

foreign import ccall safe "bridge.h getShortType"
    c_getShortType :: IO (Ptr LLVMType)

foreign import ccall safe "bridge.h getIntType"
    c_getIntType :: IO (Ptr LLVMType)

foreign import ccall safe "bridge.h getLongType"
    c_getLongType :: IO (Ptr LLVMType)

foreign import ccall safe "bridge.h getFloatType"
    c_getFloatType :: IO (Ptr LLVMType)

foreign import ccall safe "bridge.h getDoubleType"
    c_getDoubleType :: IO (Ptr LLVMType)

foreign import ccall safe "bridge.h getVoidType"
    c_getVoidType :: IO (Ptr LLVMType)

foreign import ccall safe "bridge.h getBooleanType"
    c_getBooleanType :: IO (Ptr LLVMType)

foreign import ccall safe "bridge.h getFunctionType"
    c_getFunctionType :: CInt -> Ptr (Ptr LLVMType) -> Ptr LLVMType -> CInt -> IO (Ptr LLVMType)

foreign import ccall safe "bridge.h getOpaqueObjectType"
    c_getOpaqueObjectType :: CString -> IO (Ptr LLVMType)

foreign import ccall safe "bridge.h getPointerType"
    c_getPointerType :: Ptr LLVMType -> IO (Ptr LLVMType)

getFieldTypePtr :: BString -> IO (Ptr LLVMType)
getFieldTypePtr = ret2TypePtr . br . parseOnlyFieldType
    where
        br (Right x) = x
        br (Left x) = error x

getMethodTypePtr :: Maybe (Ptr LLVMType) -> BString -> IO (Ptr LLVMType)
getMethodTypePtr p = ret2MethodPtr p . br . parseOnlyMethodType
    where
        br (Right x) = x
        br (Left x) = error x

ret2TypePtr :: FieldType -> IO (Ptr LLVMType)
ret2TypePtr (Base x)
    | x == Byte = c_getByteType
    | x == Char = c_getCharType
    | x == Short = c_getShortType
    | x == Int = c_getIntType
    | x == Long = c_getLongType
    | x == Float = c_getFloatType
    | x == Double = c_getDoubleType
    | otherwise = c_getBooleanType
ret2TypePtr (Ref (Array t)) = ret2TypePtr t >>= c_getPointerType
ret2TypePtr (Ref (Object x)) = useAsCString' x c_getOpaqueObjectType

ret2MethodPtr :: Maybe (Ptr LLVMType) -> MethodType -> IO (Ptr LLVMType)
ret2MethodPtr ptr (MethodType args ret) = arglist >>= cvt
    where
        arglist
            | isNothing ptr = mapM ret2TypePtr args
            | otherwise = (fromJust ptr :) <$> mapM ret2TypePtr args
        cvt a = retptr >>= convert (length a) a
            where
                retptr = ret2RetTypePtr ret
        convert n a r = allocaArray n $ \p
                            -> pokeArray p a
                            >> c_getFunctionType (fromIntegral n) p r 0

ret2RetTypePtr :: RetType -> IO (Ptr LLVMType)
ret2RetTypePtr (Field x) = ret2TypePtr x
ret2RetTypePtr _ = c_getVoidType


parseOnlyFieldType :: BString -> Either String FieldType
parseOnlyFieldType = parseOnly fieldType

parseOnlyMethodType :: BString -> Either String MethodType
parseOnlyMethodType = parseOnly methodType

fieldType :: Parser FieldType
fieldType = choice
    [ char 'B' >> return (Base Byte)
    , char 'C' >> return (Base Char)
    , char 'D' >> return (Base Double)
    , char 'F' >> return (Base Float)
    , char 'I' >> return (Base Int)
    , char 'J' >> return (Base Long)
    , char 'S' >> return (Base Short)
    , char 'Z' >> return (Base Boolean)
    , char 'L' >> (Ref <$> objectType)
    , char '[' >> (Ref <$> arrayType)
    ]

objectType :: Parser RefType
objectType = Object . pack <$> manyTill' anyWord8 (char ';')

arrayType :: Parser RefType
arrayType = Array <$> fieldType

methodType :: Parser MethodType
methodType = MethodType <$> params <*> ret
    where
        params = char '(' *> many' fieldType <* char ')'
        ret = choice [char 'V' *> return Void, Field <$> fieldType]


char :: Char -> Parser U1
char = word8 . charToU1

charToU1 :: Char -> U1
charToU1 = fromIntegral . ord

useAsCString' :: BString -> (CString -> IO a) -> IO a
useAsCString' = useAsCString . (`append` pack [0x00])
