module Graphics.Wayland.Scanner (
generateTypes, generateEnums, generateMethods, generateListeners,
generateRegistryBind,
generateRegistryBindInternal,
generateRegistryBindExternal,
generateClientInternalListeners,
generateServerInternalListeners,
generateClientExternalListeners,
generateServerExternalListeners,
generateClientInternalMethods,
generateServerInternalMethods,
generateClientExternalMethods,
generateServerExternalMethods,
module Graphics.Wayland.Scanner.Types,
module Graphics.Wayland.Scanner.Protocol,
CInterface(..)
) where
import Data.Functor ((<$>))
import Data.Either (lefts, rights)
import Data.Maybe (fromJust)
import Data.List (findIndex)
import Control.Monad (liftM)
import Foreign
import Foreign.C.Types
import Foreign.C.String (withCString)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (VarStrictType)
import Graphics.Wayland
import Graphics.Wayland.Scanner.Marshaller
import Graphics.Wayland.Scanner.Names
import Graphics.Wayland.Scanner.Protocol
import Graphics.Wayland.Scanner.Types
import Graphics.Wayland.Internal.Util hiding (Client)
import Graphics.Wayland.Internal.Util as Util (Client)
generateTypes :: ProtocolSpec -> Q [Dec]
generateTypes ps = liftM concat $ sequence $ map generateInterface (protocolInterfaces ps) where
generateInterface :: Interface -> Q [Dec]
generateInterface iface = do
let iname = interfaceName iface
pname = protocolName ps
qname = interfaceTypeName pname iname
constructorType <- [t|$(conT ''Ptr) $(conT qname)|]
typeDec <- newtypeD (return []) qname [] (normalC qname [return (NotStrict, constructorType)]) [mkName "Show", mkName "Eq"]
cInterfaceDec <- forImpD cCall unsafe ("&"++iname ++ "_interface") (interfaceCInterfaceName pname iname ) [t| (CInterface)|]
return $ typeDec : cInterfaceDec : []
generateRegistryBind :: ProtocolSpec -> Q [Either Dec Dec]
generateRegistryBind ps = do
let messageCreatesIface child msg = any (\ argument ->
case argument of
(_, NewIdArg _ x, _) -> x == interfaceName child
_ -> False)
(messageArguments msg)
interfaceCreatesIface child parent = any (messageCreatesIface child) (interfaceRequests parent)
protocolCreatesIface child = any (interfaceCreatesIface child) (protocolInterfaces ps)
globalInterfaces = filter (not.protocolCreatesIface) $ filter (\iface -> interfaceName iface /= "wl_display") (protocolInterfaces ps)
liftM concat $ sequence $ map registryBindInterface globalInterfaces
where
registryBindInterface :: Interface -> Q [Either Dec Dec]
registryBindInterface iface = do
let iname = interfaceName iface
pname = protocolName ps
internalCName = mkName $ "wl_registry_" ++ iname ++ "_c_bind"
exposeName = registryBindName pname iname
fore <- forImpD cCall unsafe "wl_proxy_marshal_constructor" internalCName [t|$(conT $ mkName "Registry") -> (CUInt) -> CInterface -> CUInt -> Ptr CChar -> CUInt -> Ptr () -> IO $(conT $ interfaceTypeName pname iname) |]
exposureDec <- [d|$(varP exposeName) = \ reg name strname version -> withCString strname $ \cstr -> $(varE internalCName) reg 0 $(varE $ interfaceCInterfaceName pname iname) (fromIntegral (name::Word)) cstr (fromIntegral (version::Word)) nullPtr |]
return $ Left fore : map Right exposureDec
generateEnums :: ProtocolSpec -> [Dec]
generateEnums ps = concat $ map eachGenerateEnums (protocolInterfaces ps) where
eachGenerateEnums :: Interface -> [Dec]
eachGenerateEnums iface = concat $ map generateEnum $ interfaceEnums iface where
generateEnum :: WLEnum -> [Dec]
generateEnum wlenum =
let qname = enumTypeName (protocolName ps) (interfaceName iface) (enumName wlenum)
in
NewtypeD [] qname [] (NormalC qname [(NotStrict, (ConT ''Int))]) [mkName "Show", mkName "Eq"]
:
map (\(entry, val) -> (ValD (VarP $ enumEntryHaskName (protocolName ps) (interfaceName iface) (enumName wlenum) entry) (NormalB $ (ConE qname) `AppE` (LitE $ IntegerL $ toInteger val)) [])) (enumEntries wlenum)
generateMethods :: ProtocolSpec -> ServerClient -> Q [Either Dec Dec]
generateMethods ps sc = liftM concat $ sequence $ map generateInterface $ filter (\iface -> if sc == Server then interfaceName iface /= "wl_display" else True) $ protocolInterfaces ps where
generateInterface :: Interface -> Q [Either Dec Dec]
generateInterface iface = do
let destroyName = mkName $ interfaceName iface ++ "_destructor"
foreignDestructor <- forImpD cCall unsafe "wl_proxy_destroy" destroyName [t|$(conT $ interfaceTypeName (protocolName ps) (interfaceName iface)) -> IO ()|]
let needsDefaultDestructor = ((sc == Client) && (not $ any messageIsDestructor $ interfaceRequests iface) && (interfaceName iface /= "wl_display"))
defaultDestructor <- [d|$(varP $ requestHaskName (protocolName ps) (interfaceName iface) "destroy") = \ proxy -> $(varE destroyName) proxy|]
let
generateMessage :: Int -> Message -> Q [Either Dec Dec]
generateMessage idx msg =
let pname = protocolName ps
iname = interfaceName iface
mname = messageName msg
hname = case sc of
Server -> eventHaskName pname iname mname
Client -> requestHaskName pname iname mname
internalCName = case sc of
Server -> mkName $ "wl_rpe_" ++ interfaceName iface ++ "_" ++ messageName msg
Client -> mkName $ "wl_pm_" ++ interfaceName iface ++ "_" ++ messageName msg
in case sc of
Server -> do
cdec <- forImpD cCall unsafe "wl_resource_post_event" internalCName [t|$(conT $ interfaceTypeName (protocolName ps) (interfaceName iface)) -> (CUInt) -> $(genMessageCType Nothing (messageArguments msg)) |]
resourceName <- newName "resourceInternalName___"
let messageIndexApplied = applyAtPosition (varE internalCName) (litE $ IntegerL $ fromIntegral idx) 1
resourceApplied = [e|$messageIndexApplied $(varE resourceName)|]
(pats,fun) = argTypeMarshaller (messageArguments msg) resourceApplied
declist <- [d|$(varP hname) = $(LamE (VarP resourceName : pats) <$> fun)|]
return (Left cdec:map Right declist)
Client -> do
let numNewIds = sum $ map (boolToInt . isNewId) $ messageArguments msg
argsWithoutNewId = filter (\arg -> not $ isNewId arg) (messageArguments msg)
returnArgument = head $ filter (\arg -> isNewId arg) (messageArguments msg)
returnName = let (_, NewIdArg _ theName, _) = returnArgument
in theName
returnType = [t|IO $(argTypeToCType returnArgument)|]
cdec <- case numNewIds of
0 -> forImpD cCall unsafe "wl_proxy_marshal" internalCName [t|$(conT $ interfaceTypeName (protocolName ps) (interfaceName iface)) -> (CUInt) -> $(genMessageCType Nothing (messageArguments msg)) |]
1 -> forImpD cCall unsafe "wl_proxy_marshal_constructor" internalCName [t|$(conT $ interfaceTypeName (protocolName ps) (interfaceName iface)) -> (CUInt) -> CInterface -> $(genMessageCType (Just returnType) (messageArguments msg)) |]
proxyName <- newName "proxyInternalName___"
let messageIndexApplied = applyAtPosition (varE internalCName) (litE $ IntegerL $ fromIntegral idx) 1
constructorApplied = case numNewIds of
0 -> messageIndexApplied
1 -> applyAtPosition messageIndexApplied (varE $ interfaceCInterfaceName pname (returnName)) 1
proxyApplied = [e|$constructorApplied $(varE proxyName)|]
makeArgumentNullPtr =
let argIdx = fromJust $ findIndex isNewId (messageArguments msg)
arg' = (messageArguments msg) !! argIdx
msgName = let (_,NewIdArg itsname _,_) = arg'
in itsname
in [e|$(conE msgName) nullPtr|]
newIdNullInserted = case numNewIds of
0 -> proxyApplied
1 -> applyAtPosition proxyApplied makeArgumentNullPtr (fromJust $ findIndex isNewId (messageArguments msg))
finalCall = newIdNullInserted
(pats, fun) = argTypeMarshaller (argsWithoutNewId) finalCall
declist <- [d|$(varP hname) = $(LamE (VarP proxyName : pats) <$> [e|do
retval <- $fun
$(case messageIsDestructor msg of
False -> [e|return retval|]
True -> [e|$(varE destroyName) $(varE proxyName) |]
)
return retval
|])|]
return (Left cdec : map Right declist)
theMessages <- liftM concat $ sequence $ zipWith generateMessage [0..] $
case sc of
Server -> interfaceEvents iface
Client -> interfaceRequests iface
return $ Left foreignDestructor : theMessages ++ if needsDefaultDestructor then map Right defaultDestructor else []
applyAtPosition :: ExpQ -> ExpQ -> Int -> ExpQ
applyAtPosition fun arg pos = do
vars <- sequence $ map (\ _ -> newName "somesecretnameyoushouldntmesswith___") [0..(pos1)]
lamE (map varP vars) $
appsE $ fun : (map varE vars) ++ [arg]
preComposeAt :: ExpQ -> ExpQ -> Int -> Int -> ExpQ
preComposeAt fun arg pos numArgs
| pos > numArgs = error "programming error"
preComposeAt fun arg pos numArgs = do
vars <- sequence $ map (\ _ -> newName "yetanothernewvariablepleasedonttouchme___") [0..numArgs]
lamE (map varP vars) $
[e|do
preCompVal <- $arg $(varE $ vars !! pos)
$(appsE $ fun : (map varE $ take pos vars) ++ varE 'preCompVal : (map varE $ drop (pos+1) vars))
|]
generateListeners :: ProtocolSpec -> ServerClient -> Q [Either Dec Dec]
generateListeners sp sc = do
let pname = protocolName sp
interfaces <- liftM concat $ sequence $ map (\iface -> generateListener sp iface sc) $
filter (\iface -> 0 < (length $ case sc of
Server -> interfaceRequests iface
Client -> interfaceEvents iface)) $ protocolInterfaces sp
resourceCreators <-
case sc of
Client -> return []
Server -> liftM concat $ sequence $
map (\ iface -> do
let iname = interfaceName iface
internalCName = mkName $ pname ++ "_" ++ iname ++ "_c_resource_create"
foreignDec <- forImpD cCall unsafe "wl_resource_create" internalCName [t|Util.Client -> CInterface -> CInt -> (CUInt) -> IO $(conT $ interfaceTypeName pname iname) |]
neatDec <- [d|$(varP $ interfaceResourceCreator pname iname) = \ client id ->
$(varE internalCName) client $(varE $ interfaceCInterfaceName pname iname) $(litE $ IntegerL $ fromIntegral $ interfaceVersion iface) id|]
return $ Left foreignDec : map Left neatDec
) (protocolInterfaces sp)
return $ interfaces ++ resourceCreators
generateListener :: ProtocolSpec -> Interface -> ServerClient -> Q [Either Dec Dec]
generateListener sp iface sc =
let
typeName :: Name
typeName = messageListenerTypeName sc (protocolName sp) (interfaceName iface)
pname = protocolName sp
iname :: String
iname = interfaceName iface
messages :: [Message]
messages = case sc of
Server -> interfaceRequests iface
Client -> interfaceEvents iface
mkMessageName :: Message -> Name
mkMessageName msg = case sc of
Server -> requestHaskName pname iname (messageName msg)
Client -> eventHaskName pname iname (messageName msg)
mkListenerType :: Message -> TypeQ
mkListenerType msg = case sc of
Server -> [t|Util.Client -> $(conT $ interfaceTypeName pname iname) -> $(genMessageHaskType Nothing $ messageArguments msg)|]
Client -> [t|$(conT $ interfaceTypeName pname iname) -> $(genMessageHaskType Nothing $ messageArguments msg)|]
mkListenerConstr :: Message -> VarStrictTypeQ
mkListenerConstr msg = do
let name = mkMessageName msg
ltype <- mkListenerType msg
return (name, NotStrict, ltype)
listenerType :: DecQ
listenerType = do
recArgs <- sequence $ map mkListenerConstr messages
return $ DataD [] typeName [] [RecC typeName recArgs] []
preCompResourceCreate clientName msg fun =
case sc of
Client -> fun
Server -> foldr (\(arg, idx) curFunc ->
case arg of
(_, NewIdArg _ itsName, _) -> preComposeAt curFunc [e|$(varE $ interfaceResourceCreator pname itsName) $(varE clientName) |] idx (length $ messageArguments msg)
_ -> curFunc
) fun (zip (messageArguments msg) [1..])
instanceDec :: DecsQ
instanceDec = do
[d|instance Storable $(conT typeName) where
sizeOf _ = $(litE $ IntegerL $ funcSize * (fromIntegral $ length messages))
alignment _ = $(return $ LitE $ IntegerL funcAlign)
peek _ = undefined
poke ptr record = $(doE $ ( zipWith (\ idx msg ->
noBindS [e|do
let haskFun = $(return $ VarE $ mkMessageName msg) record
unmarshaller fun = \x -> $(let (pats, funexp) = argTypeUnmarshaller (messageArguments msg) ([e|fun x|])
in LamE pats <$> funexp)
funptr <- $(case sc of
Server -> [e|$(varE $ wrapperName msg) $ \ client -> ($(preCompResourceCreate 'client msg [e|unmarshaller $ haskFun client|])) |]
Client -> [e|$(varE $ wrapperName msg) $ \ _ -> unmarshaller haskFun|])
pokeByteOff ptr $(litE $ IntegerL (idx * funcSize)) funptr
|] )
[0..] messages
) ++ [noBindS [e|return () |]] )
|]
mkListenerCType msg = case sc of
Server -> [t|Util.Client -> $(conT $ interfaceTypeName pname iname) -> $(genMessageWeirdCType Nothing $ messageArguments msg)|]
Client -> [t|Ptr () -> $(conT $ interfaceTypeName pname iname) -> $(genMessageCType Nothing $ messageArguments msg)|]
wrapperName msg = messageListenerWrapperName sc iname (messageName msg)
wrapperDec msg = forImpD cCall unsafe "wrapper" (wrapperName msg) [t|$(mkListenerCType msg) -> IO (FunPtr ($(mkListenerCType msg))) |]
haskName = requestHaskName pname iname "set_listener"
foreignName = requestInternalCName iname "c_add_listener"
foreignDec :: Q Dec
foreignDec = case sc of
Server -> forImpD cCall unsafe "wl_resource_set_implementation" foreignName [t|$(conT $ interfaceTypeName pname iname) -> (Ptr $(conT $ typeName)) -> (Ptr ()) -> FunPtr ($(conT $ interfaceTypeName pname iname) -> IO ()) -> IO ()|]
Client -> forImpD cCall unsafe "wl_proxy_add_listener" foreignName [t|$(conT $ interfaceTypeName pname iname) -> (Ptr $(conT $ typeName)) -> (Ptr ()) -> IO CInt|]
apiDec :: Q [Dec]
apiDec = [d|$(varP $ requestHaskName (protocolName sp) iname "set_listener") = \ iface listener ->
do
memory <- malloc
poke memory listener
$(case sc of
Server -> [e|$(varE foreignName) iface memory nullPtr nullFunPtr|]
Client -> [e|errToResult <$> $(varE foreignName) iface memory nullPtr|])
|]
in do
some <- sequence $ (liftM Right) listenerType : map (liftM Left . wrapperDec) messages
other <- instanceDec
more <- foreignDec
last <- apiDec
return $ some ++ (map Right other) ++ [Right more] ++ (map Right last)
generateRegistryBindInternal sp = liftM lefts $ generateRegistryBind sp
generateRegistryBindExternal sp = liftM rights $ generateRegistryBind sp
generateClientInternalListeners sp = liftM lefts $ generateListeners sp Client
generateServerInternalListeners sp = liftM lefts $ generateListeners sp Server
generateClientExternalListeners sp = liftM rights $ generateListeners sp Client
generateServerExternalListeners sp = liftM rights $ generateListeners sp Server
generateClientInternalMethods :: ProtocolSpec -> Q [Dec]
generateClientInternalMethods ps = liftM lefts $ generateMethods ps Client
generateServerInternalMethods :: ProtocolSpec -> Q [Dec]
generateServerInternalMethods ps = liftM lefts $ generateMethods ps Server
generateClientExternalMethods :: ProtocolSpec -> Q [Dec]
generateClientExternalMethods ps = liftM rights $ generateMethods ps Client
generateServerExternalMethods :: ProtocolSpec -> Q [Dec]
generateServerExternalMethods ps = liftM rights $ generateMethods ps Server
genMessageCType :: Maybe TypeQ -> [Argument] -> TypeQ
genMessageCType = genMessageType argTypeToCType
genMessageWeirdCType :: Maybe TypeQ -> [Argument] -> TypeQ
genMessageWeirdCType = genMessageType argTypeToWeirdInterfaceCType
genMessageHaskType :: Maybe TypeQ -> [Argument] -> TypeQ
genMessageHaskType = genMessageType argTypeToHaskType
genMessageType :: (Argument -> TypeQ) -> Maybe TypeQ -> [Argument] -> TypeQ
genMessageType fun Nothing args =
foldr (\addtype curtype -> [t|$(fun addtype) -> $curtype|]) [t|IO ()|] args
genMessageType fun (Just someType) args =
foldr (\addtype curtype -> [t|$(fun addtype) -> $curtype|]) someType args
snd3 :: (a,b,c) -> b
snd3 (_,b,_) = b
isNewId :: Argument -> Bool
isNewId arg = case arg of
(_, NewIdArg _ _, _) -> True
_ -> False
boolToInt :: Bool -> Int
boolToInt True = 1
boolToInt False = 0