module Language.C.Inline.ObjC.Hint (
Class(..), Struct(..), IsType
) where
import Language.Haskell.TH as TH
import Language.Haskell.TH.Syntax as TH
import Language.C.Quote as QC
import Language.C.Quote.ObjC as QC
import Language.C.Inline.Error
import Language.C.Inline.Hint
import Language.C.Inline.TH
import Language.C.Inline.ObjC.Marshal
class IsType ty where
theType :: ty -> Q TH.Type
instance IsType TH.Type where
theType = return
instance IsType (Q TH.Type) where
theType = id
instance IsType TH.Name where
theType name
= do
{ info <- reify name
; case info of
TyConI _ -> return $ ConT name
PrimTyConI _ _ _ -> return $ ConT name
FamilyI _ _ -> return $ ConT name
_ ->
do
{ reportErrorAndFail QC.ObjC $
"expected '" ++ show name ++ "' to be a type name, but it is " ++
show (TH.ppr info)
}
}
data Class where
Class :: IsType t => t -> Class
instance Hint Class where
haskellType (Class tyish)
= do
{ ty <- theType tyish
; foreignWrapperDatacon ty
; return ty
}
foreignType (Class tyish)
= do
{ name <- theType tyish >>= headTyConNameOrError QC.ObjC
; return $ Just [cty| typename $id:(nameBase name) * |]
}
showQ (Class tyish)
= do
{ ty <- theType tyish
; return $ "Class " ++ show ty
}
newForeignPtrName (Class _)
= return $ Just 'newForeignClassPtr
data Struct where
Struct :: IsType t => t -> Struct
instance Hint Struct where
haskellType (Struct tyish)
= do
{ ty <- theType tyish
; foreignWrapperDatacon ty
; return ty
}
foreignType (Struct tyish)
= do
{ name <- theType tyish >>= headTyConNameOrError QC.ObjC
; return $ Just [cty| typename $id:(nameBase name) * |]
}
showQ (Struct tyish)
= do
{ ty <- theType tyish
; return $ "Struct " ++ show ty
}
newForeignPtrName (Struct _)
= return $ Just 'newForeignStructPtr