{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE TypeSynonymInstances   #-}
{-# LANGUAGE OverlappingInstances   #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE EmptyDataDecls         #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE CPP                    #-}
{-# LANGUAGE IncoherentInstances    #-}
{-# LANGUAGE DeriveFunctor          #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Windll
-- Copyright   :  (c) Tamar Christina 2009 - 2010
-- License     :  BSD3
-- 
-- Maintainer  :  tamar@zhox.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Contains the list of native types and their mapping to their equivalent FFI types
#ifdef DEBUG
-- This module has been preprocessed to add debugging abilities to the code, including
-- an artificial stack. This combined with the methods in the debug modules should 
-- allow for better memory handling.
#endif
--
-----------------------------------------------------------------------------
#if defined(DEBUG)
module WinDll.Lib.NativeMapping_Debug where
#else
module WinDll.Lib.NativeMapping where
#endif

import FastString
import FastTypes

import Foreign.C
import Foreign.C.String
#if defined(DEBUG)
import Foreign hiding (free, malloc, alloca, realloc)
import Foreign.Marshal.Alloc hiding (free, malloc, alloca, realloc)
#else
import Foreign
import Foreign.Marshal.Alloc
#endif
import qualified Foreign.Marshal.Alloc as F
import Foreign.Marshal.Array
import Foreign.Marshal.Utils
import Foreign.Ptr
import Foreign.StablePtr

import Unsafe.Coerce

import Control.Exception (bracket)
import Control.Monad
import Control.Monad.Instances

import Data.Char
import Data.List
import Data.Word

import Data.Generics
import Data.Generics.Basics
import Data.Typeable

import WinDll.Structs.Types
import WinDll.Lib.Native
#ifdef DEBUG
import WinDll.Debug.Stack
import WinDll.Debug.Alloc
#endif

import qualified Language.Haskell.Exts as Exts


-- | Typeclase to allow Left LoaD transform. It is basically to allow a transformation to take place
--   at the last argument/return type of the function. This is because most of the functions are in IO.
class LLD m a b c | b -> c where
  lld :: m a b-> m a c
  
instance LLD (->) a b (IO b) where
  lld = (return .)

-- | A class that manages the conversion between the \normal\ and type supported by \ffi\.
--   Minimal implementation requires atleast one of the pair toNative/toFFI and fromNative/fromFFI.
--   The implementation will almost always call fromNative and toNative because all exported functions 
--   are in IO since they all might have side-effects. The only exception to this is for the defaults provided
--   in this module. 
class FFIType phi ix where
#if defined(DEBUG)
    toFFI      :: Stackable st => st -> phi -> ix
    toFFI      st = error $ show st ++ ": toFFI is undefined for the specified type, try toNative instead."
    
    fromFFI    :: Stackable st => st ->  ix -> phi
    fromFFI    st = error $ show st ++ ": fromFFI is undefined for the specified type, try fromNative instead."
    
    fromList   :: Stackable st => st -> CInt -> ix -> IO phi
    fromList st = error $ show st ++ ": fromList is undefined for this type. " 
                                  ++ "Please add a definition or consider using one of the default ones."
    
    fromNative :: Stackable st => st -> ix -> IO phi
    fromNative st = return.fromFFI st
    
    toNative :: Stackable st => st -> phi -> IO ix
    toNative st = return.toFFI st
    
    freeFFI :: Stackable st => st -> phi -> ix -> IO ()
    freeFFI = \_ _ _ -> return ();
#else
    toFFI      :: phi -> ix
    toFFI      = error "toFFI is undefined for the specified type, try toNative instead."
    
    fromFFI    :: ix -> phi
    fromFFI    = error "fromFFI is undefined for the specified type, try fromNative instead."
    
    fromList   :: CInt -> ix -> IO phi
    fromList ic = error "fromList is undefined for this type. Please add a definition or consider using one of the default ones"
    
    fromNative :: ix -> IO phi
    fromNative = return.fromFFI
    
    toNative :: phi -> IO ix
    toNative = return.toFFI
    
    freeFFI :: phi -> ix -> IO ()
    freeFFI = \_ _ -> return ();
#endif
    
-- | Default values needed to satisfy .NET marshaller when having unused structures.
-- class FFIType phi ix => FFIDefaults phi ix where
-- class Default phi where
    -- nDefault :: phi
    
-- instance Data a => Default a where 
    -- nDefault = empty
          -- where empty :: Data a => a
                -- empty = value
                  -- where
                    -- value = fromConstrB empty con
                    -- con = case dataTypeRep dat of
                             -- (AlgRep cons) -> head cons
                             -- IntRep -> mkIntegralConstr dat 0
                             -- FloatRep -> mkRealConstr dat 0
                             -- CharRep -> mkCharConstr dat 'a'
                    -- dat = dataTypeOf value    
    
-- | Wrapper functions for dealing with FunPtrs
-- wrapFn :: (FFIType (IO a) ca, FFIType b (IO cb)) => (a -> IO b) -> (ca -> IO cb)
-- wrapFn fn = fromFFI >=> fn >=> toFFI

-- unwrapFn :: (FFIType a (IO ca), FFIType (IO b) cb) => (ca -> IO cb) -> (a -> IO b)
-- unwrapFn fn a = bracket (toFFI a) (freeFFI undefined) (fn >=> fromFFI)
#if defined(DEBUG)
#define _CONST_ const
#define _ID_ const id
#define _ST_ st
#define RECORD(file,line,name,fn)  \st ptr -> record   (pushStack st (file ++ ":" ++ (show line) ++ "(" ++ name ++ ")")) ptr >> return (fn ptr)
#define RECORDM(file,line,name,fn) \st val -> recordM  (pushStack st (file ++ ":" ++ (show line) ++ "(" ++ name ++ ")")) val fn
#define FREE(file,line,name,fn)  \st _ ptr -> freeDefault (pushStack st (file ++ ":" ++ (show line) ++ "(" ++ name ++ ")")) ptr fn
#define UFREE(file,line,name,fn) \st _ ptr -> freeUnknown (pushStack st (file ++ ":" ++ (show line) ++ "(" ++ name ++ ")")) ptr fn
#define MALLOC(file,line,name) \st -> malloc (pushStack st (file ++ ":" ++ (show line) ++ "(" ++ name ++ ")"))
#else
#define _CONST_ 
#define _ID_ id
#define _ST_ 
#define RECORD(file,line,name,fn)  \ptr -> return (fn ptr)
#define RECORDM(file,line,name,fn) fn
#define FREE(file,line,name,fn)  \_ -> fn
#define UFREE(file,line,name,fn) \_ -> fn
#define MALLOC(file,line,name) malloc
#endif
    
-- | Dedicated instance for ()
instance FFIType () () where
    toFFI   = _ID_
    fromFFI = _ID_
    
-- | Numeral values are all also already FFI values, If I've read the documentation correctly 
--   Due to GHC matching only the instance heads this instance can't unfortunately be used. (Booo bad GHC)
-- instance Num a => FFIType a a where
    -- toFFI   = _ID_
    -- fromFFI = _ID_
    
-- | Booleans are by default already an FFI value
instance FFIType Bool Bool where
    toFFI   = _ID_
    fromFFI = _ID_
    
-- | Convert booleans to Cints for use when using the ccall or stdcall conventions
instance FFIType Bool CInt where
    toFFI   = _CONST_ (\x-> case x of 
                             False -> 0
                             True  -> 1)
    fromFFI = _CONST_ (\x-> case x of
                             0 -> False
                             1 -> True)
    
-- | Convert booleans to Word8 to save space for use when using the ccall or stdcall conventions
instance FFIType Bool Word8 where
    toFFI   = _CONST_ (\x-> case x of 
                             False -> 0
                             True  -> 1)
    fromFFI = _CONST_ (\x-> case x of
                             0 -> False
                             1 -> True)  
    
-- | Convert booleans to Int8 to save space for use when using the ccall or stdcall conventions
instance FFIType Bool Int8 where
    toFFI   = _CONST_ (\x-> case x of 
                               False -> 0
                               True  -> 1)
    fromFFI = _CONST_ (\x-> case x of
                             0 -> False
                             1 -> True)
    
-- | A StorablePtr instance
instance FFIType (StablePtr a) (StablePtr a) where  -- StablePtr doesn't enforce Storable. So we can't record them.
   -- fromNative = RECORD(__FILE__, __LINE__, "fromStablePtr", id)
   -- toNative   = RECORD(__FILE__, __LINE__, "toStablePtr"  , id)
   toFFI      = _ID_
   fromFFI    = _ID_
   freeFFI  _ = _CONST_ freeStablePtr -- UFREE(  __FILE__, __LINE__, "freeStablePtr", freeStablePtr)
   
-- | A FunPtr instance
instance FFIType (FunPtr a) (FunPtr a) where
   -- toNative   = RECORD(__FILE__, __LINE__, "toFunPtr"         , id)
   -- fromNative = RECORD(__FILE__, __LINE__, "fromFunPtr"       , id)
   toFFI      = _ID_
   fromFFI    = _ID_
   freeFFI  _ = _CONST_ freeHaskellFunPtr -- UFREE(  __FILE__, __LINE__, "freeHaskellFunPtr", freeHaskellFunPtr)
   
-- | Tranform functions to and from the correct types
--   TODO: Update this variant to use the impure variants, This will be an issue..
--   TODO: Can this even be defined using the native functions?
--   This instance can't be generated. It'll stay here for now, buy it can only
--   be used by types which define toFFI/fromFFI instead of toNative/fromNative
-- instance (FFIType a b, FFIType c d) => FFIType (a -> c) (b -> d) where
   -- toFFI   _ST_ f x = toFFI   _ST_ (f (fromFFI _ST_ x))
   -- fromFFI _ST_ f x = fromFFI _ST_ (f (toFFI _ST_ x))
   
newtype Pure a = Pure{ pure :: a }
  deriving Functor

-- instance FFIType a b => FFIType (Pure a) (Pure b) where
    -- toFFI      _ST_ = Pure . toFFI _ST_ . pure
    -- fromFFI    _ST_ = Pure . fromFFI _ST_ . pure
    -- toNative   _ST_ = fmap Pure . toNative _ST_ . pure
    -- fromNative _ST_ = fmap Pure . fromNative _ST_ . pure
instance FFIType (Pure Int) (Pure CInt) where
    toFFI   _ST_ = fmap (toFFI _ST_)
    fromFFI _ST_ = fmap (fromFFI _ST_)
    
instance FFIType (Pure Float) (Pure CFloat) where
    toFFI   _ST_ = fmap (toFFI _ST_)
    fromFFI _ST_ = fmap (fromFFI _ST_)
    
instance (Num a,Integral a) => FFIType (Pure Integer) (Pure a) where
    toFFI   _ST_ = fmap (toFFI _ST_)
    fromFFI _ST_ = fmap (fromFFI _ST_)
    
instance FFIType (Pure Char) (Pure CChar) where
    toFFI   _ST_ = fmap (toFFI _ST_)
    fromFFI _ST_ = fmap (fromFFI _ST_)
    
instance FFIType (Pure Rational) (Pure CDouble) where
    toFFI   _ST_ = fmap (toFFI _ST_)
    fromFFI _ST_ = fmap (fromFFI _ST_)
    
instance FFIType (Pure Char) (Pure CWchar) where
    toFFI   _ST_ = fmap (toFFI _ST_)
    fromFFI _ST_ = fmap (fromFFI _ST_)
    
instance FFIType a b => FFIType (Pure [a]) (Pure [b]) where
    toFFI   _ST_ = fmap (fmap (toFFI _ST_))
    fromFFI _ST_ = fmap (fmap (fromFFI _ST_))
    
instance ( FFIType (Pure a) (Pure b)
         , FFIType (Pure c) (Pure d)
         , FFIType c d
         , FFIType a b)
         => FFIType (Pure (a -> c)) (Pure (b -> d)) where
   toFFI _ST_ f = Pure $ to (pure f)
     where to f x = toFFI _ST_ (f (fromFFI _ST_ x))
   fromFFI _ST_ f = Pure $ from (pure f)
      where from f x = fromFFI _ST_ (f (toFFI _ST_ x))
    

-- | I decided to use a CWString because on windows this gives me a constant 16 value
instance FFIType String CWString where
    toNative   = RECORDM(__FILE__, __LINE__, "newCWString" , newCWString)
    fromNative _ST_ ptr = do {(RECORD( __FILE__, __LINE__, "peekCWString", id)) _ST_ ptr;
                              str <- peekCWString ptr;
                              -- freeFFI _ST_ "" ptr;
                              return str;}
                        
    freeFFI    = FREE(   __FILE__, __LINE__, "freeCWString", F.free)
    
-- | Intermediate conversion instance for storing values of arrays
instance (Storable a, FFIType b a) => FFIType [b] (Ptr a) where
    toNative _ST_   = (RECORDM(__FILE__, __LINE__, "newArray", (\val -> newArray =<< mapM (toNative _ST_ $!) val))) _ST_    
    fromList _ST_ x ptr = do {(RECORD(__FILE__, __LINE__, "peekArray", id)) _ST_ ptr;
                              i <- fromNative _ST_ x;
                              v <- peekArray i ptr;
                              mapM (fromNative _ST_) v;}
    
-- | Another simple identity instance, I really need to get that overlapping instances
--   looked at.
instance FFIType CWchar CWchar where
   fromFFI = _ID_
   toFFI   = _ID_
        
-- | Another simple identity instance, I really need to get that overlapping instances
--   looked at.
instance FFIType CWString CWString where
   fromFFI = _ID_
   toFFI   = _ID_
            
-- | Another simple identity instance, I really need to get that overlapping instances
--   looked at.
instance FFIType CInt CInt where
    toFFI   = _ID_
    fromFFI = _ID_
            
-- | Another simple identity instance, I really need to get that overlapping instances
--   looked at.
instance FFIType CDouble CDouble where
    toFFI   = _ID_
    fromFFI = _ID_
            
-- | Another simple identity instance, I really need to get that overlapping instances
--   looked at.
instance FFIType CLLong CLLong where
    toFFI   = _ID_
    fromFFI = _ID_
    
-- | Convert between FastString and CWString
instance FFIType FastString CWString where
    toNative   _ST_ = toNative _ST_ . unpackFS
    fromNative _ST_ = (mkFastString `fmap`) . fromNative _ST_
    
-- | Fix integers from the machine dependend values to fixed 32bit values
instance FFIType Int CInt where
    toFFI   = _CONST_ fromIntegral
    fromFFI = _CONST_ fromIntegral

-- | Instance for unboxed integers, which are first boxed then returned
-- instance FFIType FastInt CInt where
--    toFFI   = toFFI . iBox
--    fromFFI = iUnbox . fromFFI
    
-- | Fix float instances
instance FFIType Float CFloat where
    toFFI   = _CONST_ realToFrac
    fromFFI = _CONST_ realToFrac
    
-- | Any class implementing Storable has implemented enough to be considered a FFIType
instance Storable a => FFIType a (Ptr a) where
    toNative   = RECORDM(__FILE__, __LINE__, "new", new)
    fromNative = RECORD( __FILE__, __LINE__, "peek", id) >>= peek
    freeFFI    = FREE(   __FILE__, __LINE__, "free", F.free)
    
-- | Cover lists to array convertion IF the type is also an FFI type
instance Storable a => FFIType [a] (Ptr a) where
    toNative = RECORDM(__FILE__, __LINE__, "newArray", newArray) --fmap castPtr . new -- newArray
#ifdef DEBUG
    fromList st ic ptr = (RECORD( __FILE__, __LINE__, "peek", id)) st ptr >> fromNative st ic >>= \i -> peekArray i ptr --const (peek . castPtr) --peekArray
#else
    fromList ic ptr = fromNative ic >>= \i -> peekArray i ptr --const (peek . castPtr) --peekArray
#endif
    freeFFI     = FREE(   __FILE__, __LINE__, "freeArray", F.free)
    -- | Intermediate conversion instance for storing values of arrays
    
-- | One way instance for returning lists as the result of a function call.
--   We assume to have an int* as an argument and then fill that in with the
--   length
instance (FFIType a b, Storable b) => FFIType [a] (Ptr CInt -> IO (Ptr b)) where
#ifdef DEBUG
    toNative  st lst = let ln = length lst
                       in return $ \t -> do ln' <- toNative st ln
                                            poke t ln'
                                            toNative st lst
    fromNative st fn = do ptr <- (MALLOC(__FILE__, __LINE__, "malloc")) st
                          lst <- fn ptr
                          ln  <- peek ptr
                          val <- fromList st ln lst
                          (FREE(__FILE__, __LINE__, "freePtr", F.free)) st undefined ptr
                          (FREE(__FILE__, __LINE__, "freeLst", F.free)) st undefined lst
                          return $ val
#else
    toNative  lst = let ln = length lst
                    in return $ \t -> do ln' <- toNative ln
                                         poke t ln'
                                         toNative lst
    fromNative fn = do ptr <- malloc
                       lst <- fn ptr
                       ln  <- peek ptr
                       val <- fromList ln lst
                       F.free ptr
                       F.free lst
                       return $ val
#endif

-- | Simplistic instance of Storable for list.
--   untested but (new [(1::Int)..10] >>=return.castPtr >>= peekArray 10 :: IO [Int]) works   
instance Storable a => Storable [a] where
   sizeOf    _ = 4
   alignment _ = 4
#ifdef DEBUG
   poke     ptr value = do newptr <- (RECORDM(__FILE__, __LINE__, "newArray", newArray)) emptyStack value
#else
   poke     ptr value = do newptr <- newArray value
#endif
                           copyArray (castPtr ptr) newptr (length value)
#ifdef DEBUG
                           (FREE(__FILE__, __LINE__, "freeArray", F.free)) emptyStack undefined ptr
#else
                           F.free ptr
#endif

   peekElemOff ptr c  = do val <- peekArray c (castPtr ptr)
#ifdef DEBUG
                           (FREE(__FILE__, __LINE__, "freeArray", F.free)) emptyStack undefined ptr
#else
                           F.free ptr
#endif
                           return val
    
-- | Convertion instance for Integer types to CLLongs (long long)
instance (Num a,Integral a) => FFIType Integer a where
    toFFI   = _CONST_ fromInteger
    fromFFI = _CONST_ toInteger
    
-- | Instance for Functor classes
--   TODO: rewrite this.
-- instance (Functor f, FFIType a b) => FFIType (f a) (f b) where
    -- toFFI   _ST_ = fmap (toFFI   _ST_)
    -- fromFFI _ST_ = fmap (fromFFI _ST_)
    
-- -- | Instance for Functor classes directly to pointers
{- instance (Functor f, FFIType a b,Storable (f b)) => FFIType (f a) (Ptr (f b)) where
    toNative     x = new (toFFI x)
    fromNative _ x = fmap fromFFI (peek x)
 -}
        
instance FFIType Char CChar where
    toFFI   = _CONST_ castCharToCChar
    fromFFI = _CONST_ castCCharToChar
    
instance FFIType Rational CDouble where
    toFFI   = _CONST_ fromRational
    fromFFI = _CONST_ toRational
    

instance FFIType Char CWchar where
    toFFI     = _CONST_ (head.charsToCWchars.(:[]))
        where 
           charsToCWchars = foldr utf16Char [] . map ord
             where
              utf16Char c wcs
                | c < 0x10000 = fromIntegral c : wcs
                | otherwise   = let c' = c - 0x10000 in
                                fromIntegral (c' `div` 0x400 + 0xd800) :
                                fromIntegral (c' `mod` 0x400 + 0xdc00) : wcs
    fromFFI   = _CONST_ (head.cWcharsToChars.(:[]))
        where 
            cWcharsToChars = map chr . fromUTF16 . map fromIntegral
                 where
                  fromUTF16 (c1:c2:wcs)
                    | 0xd800 <= c1 && c1 <= 0xdbff && 0xdc00 <= c2 && c2 <= 0xdfff =
                      ((c1 - 0xd800)*0x400 + (c2 - 0xdc00) + 0x10000) : fromUTF16 wcs
                  fromUTF16 (c:wcs) = c : fromUTF16 wcs
                  fromUTF16 [] = []
    
-- | Tuples are not FFI compatible, As such i'll translate them to a build in tuple datatype
--   .
--   This function translates the embedded types of a Ty to the correct forms using the 
--   function translate' (see below)
translate :: Defs -> Type -> Type
translate defs = everywhere (mkT inner)
    where inner :: Exts.Name -> Exts.Name
          inner (Exts.Ident  s) = Exts.Ident  (translate' defs s)
          inner (Exts.Symbol s) = Exts.Symbol (translate' defs s)
          
-- | Translate everything but applied types. e.g. Foo Token -> FooPtr Token
--   And lists, since lists are implicitly an applied type:
--   e.g [Token] -->> [] Token -->> Ptr Token
translatePartial :: Defs -> Type -> Type
translatePartial defs (Exts.TyForall a b c) = Exts.TyForall a b (translatePartial defs c)
translatePartial defs (Exts.TyFun      a b) = Exts.TyFun (translatePartial defs a) (translatePartial defs b)
translatePartial defs (Exts.TyTuple    a b) = Exts.TyTuple a (map (translatePartial defs) b)
translatePartial defs (Exts.TyList       a) = Exts.TyList $ case isSimpleType a of
                                                              True  -> translatePrimitive defs a
                                                              False -> a
translatePartial defs (Exts.TyApp      a b) = case findStrings' a of
                                                ("IO":_) -> Exts.TyApp (translatePartial defs a) (translatePartial defs b)
                                                _        -> Exts.TyApp (translatePartial defs a) b
translatePartial defs (Exts.TyParen      a) = Exts.TyParen (translatePartial defs a)
translatePartial defs (Exts.TyInfix  a b c) = Exts.TyInfix (translatePartial defs a) b (translatePartial defs c)
translatePartial defs (Exts.TyKind     a b) = Exts.TyKind (translatePartial defs a) b
translatePartial defs                     x = translate defs x

-- | Check to see if the next type is a Simple type. e.g. A TyVar or TyCon
isSimpleType :: Type -> Bool
isSimpleType (Exts.TyApp _  _ ) = False
isSimpleType (Exts.TyParen  a ) = isSimpleType a
-- isSimpleType (Exts.TyList   _ ) = False
isSimpleType _                  = True

-- | Contrary to translate translatePrimitive will only transform the defined
--   primitive types in the \convList\ below. This is because while a transformed
--   signature should only be partially transformed till the first application (Since that'll be
--   the main pointer) we should pre-transform the primitive types into their well known static forms.
translatePrimitive :: Defs -> Type -> Type
translatePrimitive defs = everywhere (mkT inner)
    where inner :: Exts.Name -> Exts.Name
          inner (Exts.Ident  s) = Exts.Ident  (translateP defs s)
          inner (Exts.Symbol s) = Exts.Symbol (translateP defs s)
          
-- | Helper function to define translatePrimitive. It attemps to lookup the type in \convList\ but
--   in the case where it's not found the search query is returned.
translateP :: Defs -> String -> String
translateP convList x = 
   let sType = all isLower x
   in if sType then x else maybe x id (lookup x convList)

-- | Translate Partial Form, This is basically translatePrimitive . translatePartial
translatePForm :: Defs -> Type -> Type
translatePForm df = translatePrimitive df . translatePartial df
               
-- |  Look up the FFI type representation of the given type. Moreover when the type is not found
-- it is assumed to be a new structure and it is assumed to be a pointer value.
translate' :: Defs -> String -> String
translate' convList x = let sType = all isLower x
                        in if sType then x else ((flip maybe id . (++ "Ptr")) `ap` (flip lookup convList)) x
          
-- | Remove all spaces from a sentence
trim :: String -> String
trim = filter (/=' ')
    
-- | A function to split a list of elements by the given seperator
split :: Eq a => [a] -> a -> [[a]]
split []     _             = [[]]
split (x:xs) t | t==x      = [] : (split xs t)
               | otherwise = let (f:fs) = split xs t
                             in (x:f):fs