module Foreign.HacanonLight.DIS.StdDIS
    ( emptyDIS
    , tuple
    , anonPtr
    , cstring
    , cast
    , int
    , float
    , unit
    , enum
    , enum'
    , bool
    , string
    , mkIn
    , mkInOut
    , mkOut
    , char
    , double
    , persistent
    , hsStruct
    , maybe
    , dynamic
    , maybeInt
    , maybePtr
    , cPointer
    , hsPointer
    , foreignPtr
    , word32
    , word16
    , word8
    , int32
    , int16
    , int8
    ) where

import Foreign.HacanonLight.Common.THUtils
    (createTupleType
    ,createSimpleType)
import Foreign.HacanonLight.DIS.Types

import Foreign.C.String
import Foreign

import Language.Haskell.TH

import Prelude hiding (maybe)
import Data.Word
import Data.Int


var name = varE (mkName name)

--------------------------------------------------------------
-- Helper schemes.
--------------------------------------------------------------

emptyDIS :: DIS
emptyDIS =
    MkDIS { disOperation = DISIn
          , disType      = undefined
          , disFFIType   = undefined
          , disMarshal   = undefined
          , disMarshalP  = undefined
          , disUnMarshal = undefined
          , disFree      = undefined }
    where undefined = error "emptyDIS"

tuple :: [DIS] -> DIS
tuple [x] = x
tuple schemes =
    emptyDIS { disOperation = DISOut
             , disType      = createTupleType types
             , disFFIType   = error "No corresponding FFI type for a tuple."
             , disUnMarshal = unmarshal
             , disFree      = (\n -> [| $(varE (mkName "return")) () |]) }
    where types = map disType schemes
          unmarshals = (map disUnMarshal schemes)
          doExpr (pat,unmar) = unmar (varE pat)
          returnExpr retVars = [| $(varE (mkName "return")) $(tuples) |]
              where tuples = tupE (map varE retVars)
          unmarshal n =
              do patterns <- mapM (const (newName "tuplePart")) schemes
                 retVars <- mapM (const (newName "returnVariable")) schemes
                 caseE n [match (tuples patterns) (normalB (doE (allStmts patterns retVars))) []]
              where tuples       = tupP . map varP
                    exprs p      = map doExpr (zip p unmarshals)
                    stmts p r    = map (\(exp,var) -> bindS (varP var) exp) (zip (exprs p) r)
                    allStmts p r = stmts p r ++ [noBindS (returnExpr r)]



hsPointer :: DIS -> DIS
hsPointer dis = 
    dis { disFFIType     = appT (conT (mkName "Ptr")) (disFFIType dis)
        , disType        = appT (conT (mkName "Ptr")) (disType dis)
        , disMarshal     = (\n -> [| \action -> action $(n)|])
        , disMarshalP    = (\n -> [| $(varE (mkName "return")) $(n)|])
        , disUnMarshal   = (\n -> [| $(varE (mkName "return")) $(n) |])
        , disFree        = (\n -> [| do value <- $(varE (mkName "peek")) $(n)
                                        $(disFree dis [| value |])
                                        $(varE (mkName "free")) $(n)
                                   |]) }

cPointer :: DIS -> DIS
cPointer dis = 
    (hsPointer dis) { disType = disType dis }


cast :: TypeQ -> DIS
cast t =
    emptyDIS { disType      = t
             , disFFIType   = t
             , disMarshal   = (\n -> [| \action -> action $(n) |] )
             , disMarshalP  = (\n -> [| $(varE (mkName "return")) $(n) |] )
             , disUnMarshal = (\n -> [| $(varE (mkName "return")) $(n) |] )
             , disFree      = (\n -> [| $(varE (mkName "return")) () |]) }

dynamic :: DIS -> DIS
dynamic dis =
    dis { disUnMarshal = newUnMarshal }
    where newUnMarshal = (\n -> [| do value <- $(disUnMarshal dis n)
                                      $(disFree dis n)
                                      return value |])


setOperation :: DISOperation -> DIS -> DIS
setOperation opr dis =
    dis { disOperation = opr }
             
mkOut :: DIS -> DIS
mkOut dis =
    dis { disOperation = DISOut
        , disMarshal   = (\n -> varE (mkName "alloca"))
        , disMarshalP  = (\n -> varE (mkName "malloc"))
        , disUnMarshal = (\n -> [| do n <- $(varE (mkName "peek")) $(n)
                                      $(disUnMarshal dis [| n |]) |])
        , disFFIType   = conT (mkName "Ptr") `appT` disFFIType dis }


mkInOut :: DIS -> DIS
mkInOut dis =
    dis { disOperation = DISInOut
        , disMarshal   = (\n -> [| $(disMarshal dis n) $(varE (mkName "with")) |])
        , disMarshalP  = (\n -> [| $(disMarshalP dis n) >>= $(varE (mkName "new")) |])
        , disUnMarshal = (\n -> [| $(varE (mkName "peek")) $(n) >>= \n -> $(disUnMarshal dis [| n |]) |])
        , disFFIType   = conT (mkName "Ptr") `appT` disFFIType dis 
        }
mkIn :: DIS -> DIS
mkIn = setOperation DISIn

persistent :: DIS -> DIS
persistent dis =
    dis { disMarshal = (\n -> [| \action -> action =<< $(disMarshalP dis n) |]) }

maybePtr :: DIS -> DIS
maybePtr = maybe (varE (mkName "nullPtr"))

maybeInt :: DIS -> DIS
maybeInt = maybe [| 0 |]

maybe :: ExpQ -> DIS -> DIS
maybe expr dis =
    dis { disType = appT (conT (mkName "Maybe")) (disType dis)
        , disMarshal = newMarshal
        , disMarshalP = newMarshalP
        , disUnMarshal = newUnMarshal
        , disFree = newFree
        }
    where newMarshal   = (\n -> [| case $(n) of
                                     Just a  -> $(disMarshal dis [| a |])
                                     Nothing -> (\action -> action $(expr)) |])
          newMarshalP  = (\n -> [| case $(n) of
                                     Just a  -> $(disMarshalP dis [| a |])
                                     Nothing -> $(expr) |])
          newUnMarshal = (\n -> [| if $(infixE (Just n) (varE (mkName "==")) (Just expr))
                                     then $(varE (mkName "return")) $(varE (mkName "Nothing"))
                                     else $(varE (mkName "fmap")) $(varE (mkName "Just")) $(disUnMarshal dis n) |])
          newFree      = (\n -> [| if $(n) $(varE (mkName "==")) $(expr)
                                     then $(disFree dis n)
                                     else $(varE (mkName "return")) $(varE (mkName "()")) |])

enum :: String -> DIS
enum = enum' "fromEnum" "toEnum" (conT (mkName "Int"))

enum' :: String -> String -> TypeQ -> String -> DIS
enum' from to t name =
    emptyDIS { disOperation = DISIn
             , disType      = conT (mkName name)
             , disFFIType   = t
             , disMarshal   = (\n -> [| \action -> action ($(varE (mkName from)) $(n)) |])
             , disMarshalP  = (\n -> [| $(varE (mkName "return")) ($(varE (mkName from)) $(n)) |])
             , disUnMarshal = (\n -> [| $(varE (mkName "return")) ($(varE (mkName to)) $(n)) |]) }

{-
bitmask :: String -> DIS
bitmask name =
    (enum name) { disType      = listT `appT` conT (mkName name)
                , disMarshal   = (\n -> [| \action -> action (toBitmask $(n)) |])
                , disMarshalP  = (\n -> [| return (toBitmask $(n)) |])
                , disUnMarshal = (\n -> [| return (fromBitmask $(n)) |]) }
-}

hsStruct :: [DIS] -> String -> DIS
hsStruct parameters name =
    emptyDIS { disOperation = DISIn
             , disType      = conT (mkName name) `appT` disType tup
             , disFFIType   = conT (mkName "Ptr") `appT` (conT (mkName name) `appT` disType tup)
             , disMarshal   = (\n -> [| \action -> alloca (\ptr -> poke ptr $(n) >> action ptr) |])
             , disMarshalP  = (\n -> [| malloc >>= \ptr -> poke ptr $(n) >> return ptr |])
             , disUnMarshal = (\n -> [| peek $(n) |])
             }
    where tup = tuple parameters

--------------------------------------------------------------
-- Standard interfacing schemes
--------------------------------------------------------------


anonPtr :: DIS
anonPtr = cast (conT (mkName "Ptr") `appT` conT (mkName "()"))

unit :: DIS
unit =
    emptyDIS { disOperation = DISIgnore
             , disType      = conT (mkName "()")
             , disFFIType   = conT (mkName "()")
             }

float :: DIS
float = cast (conT (mkName "Float"))

int :: DIS
int = cast (conT (mkName "Int"))

double :: DIS
double = cast (conT (mkName "Double"))

char :: DIS
char = cast (conT (mkName "Char"))

word32 :: DIS
word32 = cast (conT (mkName "Word32"))

word16 :: DIS
word16 = cast (conT (mkName "Word16"))

word8 :: DIS
word8 = cast (conT (mkName "Word8"))

int32 :: DIS
int32 = cast (conT (mkName "Int32"))

int16 :: DIS
int16 = cast (conT (mkName "Int16"))

int8 :: DIS
int8 = cast (conT (mkName "Int8"))

bool :: DIS
bool =
    emptyDIS { disType      = conT (mkName "Bool")
             , disFFIType   = conT (mkName "Int")
             , disMarshal   = (\n -> [| \action -> action ($(varE (mkName "fromBool")) $(n)) |])
             , disMarshalP  = (\n -> [| $(varE (mkName "return")) ($(varE (mkName "fromBool")) $(n)) |])
             , disUnMarshal = (\n -> [| $(varE (mkName "return")) ($(varE (mkName "toBool")) $(n)) |])
             , disFree      = (\n -> [| $(varE (mkName "return")) () |]) }

cstring :: DIS
cstring = cast (conT (mkName "CString"))

string :: DIS
string =
    emptyDIS { disType      = conT (mkName "String")
             , disFFIType   = conT (mkName "CString")
             , disMarshal   = (\n -> [| $(varE (mkName "withCString")) $(n) |])
             , disMarshalP  = (\n -> [| $(varE (mkName "newCString")) $(n) |])
             , disUnMarshal = (\n -> [| $(varE (mkName "peekCString")) $(n) |])
             , disFree      = (\n -> [| $(varE (mkName "free")) $(n) |]) }


foreignPtr :: String -> String -> String -> DIS
foreignPtr name struct finalizer =
    emptyDIS { disType      = conT (mkName name)
             , disFFIType   = conT (mkName "Ptr") `appT` conT (mkName struct)
             , disMarshal   = (\n -> [| $(varE (mkName "withForeignPtr")) $(n) |])
             , disMarshalP  = (\n -> [| $(varE (mkName "undefined")) $(n) |])
             , disUnMarshal = (\n -> [| $(varE (mkName "newForeignPtr")) $(varE (mkName finalizer)) $(n) |]) }