module System.Posix.DynamicLinker.Template
( makeDynamicLinker
, Callconv(..)
, DL
, FunPtr
)
where
import System.Posix.DynamicLinker
import Language.Haskell.TH.Syntax
import Control.Monad (when, unless, join)
import Foreign.Ptr
import Foreign.C.String
import Data.Traversable (traverse)
import Data.Foldable (traverse_)
import Data.Map (fromList, lookup)
import Data.Maybe (isNothing, fromJust, Maybe)
import Data.Functor (fmap)
makeDynamicLinker :: Name
-> Callconv
-> Name
-> Q [Dec]
makeDynamicLinker dt callconv symMod = do
info <- reify dt
reified <- case info of
TyConI dec -> return dec
_ -> fail $ errmsg dt
(name,cons) <- case reified of
DataD [] _ [] _ [RecC name cons'] _ -> return (name,cons')
NewtypeD [] _ [] _ (RecC name cons') _ -> return (name,cons')
_ -> fail $ errmsg dt
unless (any ((==) "libHandle" . extractName) cons) $
qReport True (nolibhandlemsg dt)
let symbols = filter ((/=) "libHandle" . extractName) 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 (newName . ("make_" ++) . extractName) symbols
foreigns <- mapM (\(t,mk) -> makeForeign funptr t mk) (realTypes `zip` makes)
when (null foreigns) $ qReport False (nodefmsg dt)
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" ++) dt
extractName (Name name _, _, _) = occString name
transformName :: (String -> String) -> Name -> Name
transformName namer (Name occ f) = Name newNam f
where newNam = mkOccName $ namer $ occString occ
transformNameLocal :: (String -> String) -> Name -> Name
transformNameLocal namer n = Name occ NameS
where
Name occ _ = transformName namer n
makeForeign :: Type -> Type -> Name -> Q Dec
makeForeign fptr typ mk = do
let importTyp = AppT (AppT ArrowT (AppT fptr typ)) typ
return (ForeignD (ImportF callconv Safe "dynamic" mk importTyp))
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
pick a = join $ fmap (fromFunPtr . castFunPtr) $ Data.Map.lookup a symPtrs
missingmsg name lib' = "Mandatory symbol \"" ++ name ++ "\" was not found in " ++ lib'
checkSym (name,opt) = when (not opt && isNothing (pick name)) $ error (missingmsg name lib)
traverse_ checkSym (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 or because it has more than one constructor"
++ "\n Did you remember to double-tick the type as in"
++ "\n $(makeDynamicLinker ''TheType)?"