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)
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)) |]) }
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
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) |]) }