module System.Posix.DynamicLinker.Template (
makeDynamicLinker
) where
import Language.Haskell.TH.Syntax
import Control.Monad (liftM, when, unless, liftM2)
import Data.List (nub)
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)
makeDynamicLinker :: Name -> Q [Dec]
makeDynamicLinker t = do
info <- reify t
reified <- case info of
TyConI dec -> return dec
_ -> fail $ errmsg t
decMakeDynamicLinker t reified
decMakeDynamicLinker :: Name -> Dec -> Q [Dec]
decMakeDynamicLinker t dec = do
(name,cons) <- case dec 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 cons2 = filter (\(Name name _,_,_) -> occString name /= "libHandle") cons
decs <- makeDL name cons2
when (null decs) $ qReport False (nodefmsg t)
return decs
makeDL :: Name -> [VarStrictType] -> Q [Dec]
makeDL s vars = do
foreigns <- mapM (\ (name,_,ftype) -> makeForeign name ftype) vars
loader <- makeLoader s $ map (\ (n,_,_) -> n) vars
return (loader ++ foreigns)
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
nameMake :: Name -> Name
nameMake = transformNameLocal ("make_" ++)
makeForeign :: Name -> Type -> Q Dec
makeForeign name typ = do
let n = nameMake name
let fptr = mkName "Foreign.Ptr.FunPtr"
return . ForeignD $ ImportF CCall Safe "dynamic" n (AppT (AppT ArrowT (AppT (ConT fptr) typ)) typ)
makeLoader :: Name -> [Name] -> Q [Dec]
makeLoader t ss = do
body <- [|
\lib -> do
dl <- dlopen lib [RTLD_NOW,RTLD_LOCAL]
let symbls = $(return symbols)
let mydlsym s = withCAString s $ c_dlsym (packDL dl)
symPtrs <- traverse mydlsym symbls
let syms = fromList $ symbls `zip` symPtrs
let pick a = fmap castFunPtr $ Data.Map.lookup a syms
let unsafePick a = fromMaybe nullFunPtr $ pick a
let notFound a = error ("Mandatory symbol \"" ++ a ++ "\" not found in " ++ lib)
let mandatory a = if isNothing (pick a) then notFound a else unsafePick a
return $(liftM2 libHandle [| dl |] [| mandatory |])
|]
let load = FunD loadName [Clause [] (NormalB body) []]
return [load]
where
symbols = ListE $ map (\ (Name occ _) -> LitE $ StringL $ occString occ) ss
makes = map nameMake ss
loadName = transformNameLocal ("load" ++) t
fields mand = map (\(field@(Name occ _),mk) -> (field, AppE (VarE mk) (AppE mand (LitE $ StringL $ occString occ)))) $ zip ss makes
libHandle dl mand = RecConE t ((Name (mkOccName "libHandle") NameS, dl) : fields mand)
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)?"