{-# LANGUAGE
  TemplateHaskell,
  MultiParamTypeClasses,
  FunctionalDependencies,
  UndecidableInstances
  #-}
module LLVM.Internal.Coding where

import LLVM.Prelude

import Language.Haskell.TH
import Language.Haskell.TH.Quote

import Control.Monad.AnyCont
import Control.Monad.IO.Class

import Foreign.C
import Foreign.Ptr
import Foreign.Storable
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array

import qualified LLVM.Internal.FFI.LLVMCTypes as FFI

class EncodeM e h c where
  encodeM :: h -> e c

class DecodeM d h c where
  decodeM :: c -> d h

genCodingInstance :: (Data c, Data h) => TypeQ -> Name -> [(c, h)] -> Q [Dec]
genCodingInstance ht ctn chs = do
  let n = const Nothing
  [d| 
    instance Monad m => EncodeM m $(ht) $(conT ctn) where
      encodeM h = return $ $(
        caseE [| h |] [ match (dataToPatQ n h) (normalB (dataToExpQ n c)) [] | (c,h) <- chs ] 
       )

    instance Monad m => DecodeM m $(ht) $(conT ctn) where
      decodeM c = return $ $(
        caseE [| c |] ([ match (dataToPatQ n c) (normalB (dataToExpQ n h)) [] | (c,h) <- chs] ++
                       [ match wildP (normalB [e| error ("Decoding failed: Unknown " <> show c) |]) []]))
   |]

allocaArray :: (Integral i, Storable a, MonadAnyCont IO m) => i -> m (Ptr a)
allocaArray p = anyContToM $ Foreign.Marshal.Array.allocaArray (fromIntegral p)

alloca :: (Storable a, MonadAnyCont IO m) => m (Ptr a)
alloca = anyContToM Foreign.Marshal.Alloc.alloca

peek :: (Storable a, MonadIO m) => Ptr a -> m a
peek p = liftIO $ Foreign.Storable.peek p

peekByteOff :: (Storable a, MonadIO m) => Ptr a -> Int -> m a
peekByteOff p i = liftIO $ Foreign.Storable.peekByteOff p i

poke :: (Storable a, MonadIO m) => Ptr a -> a -> m ()
poke p a = liftIO $ Foreign.Storable.poke p a

pokeByteOff :: (Storable a, MonadIO m) => Ptr a -> Int -> a -> m ()
pokeByteOff p i a = liftIO $ Foreign.Storable.pokeByteOff p i a

peekArray :: (Integral i, Storable a, MonadIO m) => i -> Ptr a -> m [a]
peekArray n p = liftIO $ Foreign.Marshal.Array.peekArray (fromIntegral n) p

instance (Monad m, EncodeM m h c, Storable c, MonadAnyCont IO m) => EncodeM m [h] (CUInt, Ptr c) where
  encodeM hs = do
    hs <- mapM encodeM hs
    (anyContToM $ \x -> Foreign.Marshal.Array.withArrayLen hs $ \n hs -> x (fromIntegral n, hs))

instance (Monad m, DecodeM m h c, Storable c, MonadIO m) => DecodeM m [h] (CUInt, Ptr c) where
  decodeM (n, ca) = do
    cs <- liftIO $ Foreign.Marshal.Array.peekArray (fromIntegral n) ca
    mapM decodeM cs

instance Monad m => EncodeM m Bool FFI.LLVMBool where
  encodeM False = return $ FFI.LLVMBool 0
  encodeM True = return $ FFI.LLVMBool 1

instance Monad m => DecodeM m Bool FFI.LLVMBool where
  decodeM (FFI.LLVMBool 0) = return $ False
  decodeM (FFI.LLVMBool _) = return $ True

instance (Monad m, EncodeM m h (Ptr c)) => EncodeM m (Maybe h) (Ptr c) where
  encodeM = maybe (return nullPtr) encodeM

instance (Monad m, DecodeM m h (Ptr c)) => DecodeM m (Maybe h) (Ptr c) where
  decodeM p | p == nullPtr = return Nothing
            | otherwise = liftM Just $ decodeM p

instance Monad m => EncodeM m (Maybe Bool) (FFI.NothingAsMinusOne Bool) where
  encodeM = return . FFI.NothingAsMinusOne . maybe (-1) (fromIntegral . fromEnum)

instance Monad m => EncodeM m (Maybe Word) (FFI.NothingAsMinusOne Word) where
  encodeM = return . FFI.NothingAsMinusOne . maybe (-1) fromIntegral

instance Monad m => EncodeM m (Maybe Word32) (CUInt, FFI.LLVMBool) where
  encodeM (Just a) = liftM2 (,) (encodeM a) (encodeM True)
  encodeM Nothing = return (0,) `ap` (encodeM False)

instance Monad m => DecodeM m (Maybe Word32) (CUInt, FFI.LLVMBool) where
  decodeM (a, isJust) = do
    isJust' <- decodeM isJust
    if isJust'
       then liftM Just (decodeM a)
       else return Nothing

instance Monad m => EncodeM m Word CUInt where
  encodeM = return . fromIntegral

instance Monad m => EncodeM m Word32 CUInt where
  encodeM = return . fromIntegral

instance Monad m => EncodeM m Word64 CULong where
  encodeM = return . fromIntegral

instance Monad m => DecodeM m Word CUInt where
  decodeM = return . fromIntegral

instance Monad m => DecodeM m Word32 CUInt where
  decodeM = return . fromIntegral

instance Monad m => DecodeM m Word64 CULong where
  decodeM = return . fromIntegral

instance Monad m => EncodeM m Int32 CInt where
  encodeM = return . fromIntegral

instance Monad m => DecodeM m Int32 CInt where
  decodeM = return . fromIntegral

instance Monad m => DecodeM m Int CInt where
  decodeM = return . fromIntegral

instance Monad m => EncodeM m Word64 Word64 where
  encodeM = return

instance Monad m => DecodeM m Word64 Word64 where
  decodeM = return