module Language.C.Inline.Hint (
Annotated(..), (<:), void, annotatedShowQ,
Hint(..),
haskellTypeOf, foreignTypeOf, newForeignPtrOf, stripAnnotation
) where
import Control.Applicative
import Language.Haskell.TH as TH
import Language.Haskell.TH.Syntax as TH
import Language.C.Quote as QC
import Language.C.Inline.Error
data Annotated e where
(:>) :: Hint hint => e -> hint -> Annotated e
Typed :: Name -> Annotated Name
(<:) :: Hint hint => hint -> e -> Annotated e
(<:) = flip (:>)
void :: e -> Annotated e
void = (''() <:)
annotatedShowQ :: Show e => Annotated e -> Q String
annotatedShowQ (e :> hint) = ((show e ++ " :> ") ++) <$> showQ hint
annotatedShowQ (Typed name) = return $ "Typed " ++ show name
class Hint hint where
haskellType :: hint -> Q TH.Type
foreignType :: hint -> Q (Maybe QC.Type)
showQ :: hint -> Q String
newForeignPtrName :: hint -> Q (Maybe TH.Name)
instance Hint Name where
haskellType = conT
foreignType = const (return Nothing)
showQ = return . show
newForeignPtrName = const (return Nothing)
instance Hint (Q TH.Type) where
haskellType = id
foreignType = const (return Nothing)
showQ = (show <$>)
newForeignPtrName = const (return Nothing)
haskellTypeOf :: Annotated e -> Q TH.Type
haskellTypeOf (_ :> hint) = haskellType hint
haskellTypeOf (Typed name)
= do
{ info <- reify name
; case info of
ClassOpI _ ty _ -> return ty
VarI _ ty _ -> return ty
nonVarInfo ->
do
{ reportErrorAndFail QC.ObjC $
"expected '" ++ show name ++ "' to be a typed variable name, but it is " ++
show (TH.ppr nonVarInfo)
}
}
foreignTypeOf :: Annotated e -> Q (Maybe QC.Type)
foreignTypeOf (_ :> hint) = foreignType hint
foreignTypeOf (Typed name) = return Nothing
newForeignPtrOf :: Annotated e -> Q (Maybe TH.Name)
newForeignPtrOf (_ :> hint) = newForeignPtrName hint
newForeignPtrOf (Typed name) = return Nothing
stripAnnotation :: Annotated e -> e
stripAnnotation (e :> hint) = e
stripAnnotation (Typed name) = name