module System.Posix.DynamicLinker.Template (
makeDynamicLinker, Callconv(..), DL, id, FunPtr
) where
import Language.Haskell.TH.Syntax
import Control.Monad (liftM, when, unless, liftM2, void, join)
import Data.List (nub)
import Data.Functor ( (<$>), fmap )
import System.Posix.DynamicLinker
import Foreign.Ptr
import Foreign.C.String
import Data.Traversable(traverse)
import Data.Map (fromList,lookup)
import Data.Maybe (fromMaybe, isNothing, fromJust,Maybe)
makeDynamicLinker :: Name
-> Callconv
-> Name
-> Q [Dec]
makeDynamicLinker t callconv symMod = do
info <- reify t
reified <- case info of
TyConI dec -> return dec
_ -> fail $ errmsg t
(name,cons) <- case reified of
DataD [] _ [] [RecC name cons'] _ -> return (name,cons')
NewtypeD [] _ [] (RecC name cons') _ -> return (name,cons')
_ -> fail $ errmsg t
unless (any (\(Name name _,_,_) -> occString name == "libHandle") cons) $ qReport True (nolibhandlemsg t)
let symbols = filter (\(Name name _,_,_) -> occString name /= "libHandle") cons
maybeType <- [t| Data.Maybe.Maybe |]
funptr <- [t| Foreign.Ptr.FunPtr |]
let names = map (\ (n,_,_) -> n) symbols
let (optionals,realTypes) = unzip $ map (\(_,_,t) -> isMaybe maybeType t) symbols
let symbolsE = ListE $ map (\ (Name occ _) -> LitE $ StringL $ occString occ) names
makes <- mapM (\((Name occ _),_,_) -> newName $ "make_" ++ occString occ) symbols
foreigns <- mapM (\ (n,t,mk) -> makeForeign funptr n t mk) (zip3 names realTypes makes)
when (null foreigns) $ qReport False (nodefmsg t)
loader <- makeLoader name names optionals makes symbolsE
return (foreigns ++ loader)
where
isMaybe :: Type -> Type -> (Bool,Type)
isMaybe maybeType (AppT mb t) | mb == maybeType = (True,t)
isMaybe _ t = (False,t)
loadName = transformNameLocal ("load" ++) t
transformName :: (String -> String) -> Name -> Name
transformName namer (Name occ f) = Name newName f
where newName = mkOccName $ namer $ occString occ
transformNameLocal :: (String -> String) -> Name -> Name
transformNameLocal namer n = Name occ NameS
where
Name occ _ = transformName namer n
makeForeign :: Type -> Name -> Type -> Name -> Q Dec
makeForeign fptr name typ mk = do
return . ForeignD $ ImportF callconv Safe "dynamic" mk (AppT (AppT ArrowT (AppT fptr typ)) typ)
makeLoader :: Name -> [Name] -> [Bool] -> [Name] -> Exp -> Q [Dec]
makeLoader t names optionals makes symbolsE = do
body <- [| \lib flags -> do
dl <- dlopen lib flags
let symbls = $(return symbolsE)
let modSymbols = fmap $(return $ VarE symMod) symbls
let mydlsym s = withCAString s $ c_dlsym (packDL dl)
ptrs <- traverse mydlsym modSymbols
let symPtrs = fromList $ modSymbols `zip` ptrs
let fromFunPtr a = if a == nullFunPtr then Nothing else Just a
let pick a = join $ fmap (fromFunPtr . castFunPtr) $ Data.Map.lookup a symPtrs
void $ traverse (\(name,opt) -> do
when (not opt && isNothing (pick name)) $ error ("Mandatory symbol \"" ++ name ++ "\" was not found in " ++ lib)
) (zip modSymbols $(lift $ optionals))
return $( do
hdl <- [| dl |]
let handleField = (Name (mkOccName "libHandle") NameS, hdl)
pick <- [| pick |]
fm <- [| Data.Functor.fmap |]
fds <- traverse (\(sym,isOpt,mk) -> makeField mk isOpt pick fm sym) (zip3 names optionals makes)
return $ RecConE t (handleField:fds)
)
|]
sigType <- [t| FilePath -> [RTLDFlags] -> IO $(return $ ConT $ transformNameLocal id t) |]
let load = FunD loadName [Clause [] (NormalB body) []]
return [SigD loadName sigType,load]
literalize (Name occ _) = LitE $ StringL $ occString occ
makeField :: Name -> Bool -> Exp -> Exp -> Name -> Q FieldExp
makeField mk isOptional pick fm name = do
op <- if isOptional then [| id |] else [| fromJust |]
return (name, AppE op $ AppE (AppE fm (VarE mk)) $ AppE pick $ AppE (VarE symMod) $ literalize name)
nodefmsg t = "Warning: No dynamic linker method generated from the name " ++ show t
nolibhandlemsg t = "You must add a field 'libHandle :: System.Posix.DynamicLinker.Prim.DL' in your data " ++ show t
errmsg t = "Cannot derive dynamic linker methods for name " ++ show t ++ " because"
++ "\n it is not a type declared with 'data' or 'newtype'"
++ "\n Did you remember to double-tick the type as in"
++ "\n $(makeDynamicLinker ''TheType)?"