diff options
author | Matthias Schiffer <mschiffer@universe-factory.net> | 2011-09-07 16:38:36 +0200 |
---|---|---|
committer | Matthias Schiffer <mschiffer@universe-factory.net> | 2011-09-07 16:38:36 +0200 |
commit | 15d9304e052d2e5d4416e54a6fd24fbd0a252964 (patch) | |
tree | 0c9384b5fa0554ac7fd6deb7bc4a077b065e8a7c /lib/Phi/X11/Atoms.hs | |
parent | 42d5f27d32c74b29545ce0922e55407fa5ccc7fc (diff) | |
download | phi-15d9304e052d2e5d4416e54a6fd24fbd0a252964.tar phi-15d9304e052d2e5d4416e54a6fd24fbd0a252964.zip |
Converted core to XHB/XCB
Diffstat (limited to 'lib/Phi/X11/Atoms.hs')
-rw-r--r-- | lib/Phi/X11/Atoms.hs | 32 |
1 files changed, 22 insertions, 10 deletions
diff --git a/lib/Phi/X11/Atoms.hs b/lib/Phi/X11/Atoms.hs index acbae64..0a8f66a 100644 --- a/lib/Phi/X11/Atoms.hs +++ b/lib/Phi/X11/Atoms.hs @@ -5,36 +5,48 @@ module Phi.X11.Atoms ( Atoms(..) ) where import Control.Monad +import Data.Char +import Data.List + import Language.Haskell.TH -import Graphics.X11 +import Graphics.XHB +import Graphics.XHB.Gen.Xproto import Phi.X11.AtomList $(let atomsName = mkName "Atoms" atomNames = map (\atom -> (atom, mkName ("atom" ++ atom))) $ atoms ++ (map fst specialAtoms) - fields = map (\(_, name) -> (name, IsStrict, ConT ''Atom)) atomNames + fields = map (\(_, name) -> (name, IsStrict, ConT ''ATOM)) atomNames in return [DataD [] atomsName [] [RecC atomsName fields] []] ) -initAtoms :: Display -> IO Atoms -initAtoms display = +initAtoms :: Connection -> IO Atoms +initAtoms conn = $(do normalAtomNames <- mapM (\atom -> do + receiptName <- newName ('_':atom) varName <- newName ('_':atom) - return ([|const atom|], mkName ("atom" ++ atom), varName) + return ([|const atom|], mkName ("atom" ++ atom), receiptName, varName) ) atoms specialAtomNames <- mapM (\(name, atomgen) -> do + receiptName <- newName ('_':name) varName <- newName ('_':name) - return (atomgen, mkName ("atom" ++ name), varName) + return (atomgen, mkName ("atom" ++ name), receiptName, varName) ) specialAtoms let atomNames = normalAtomNames ++ specialAtomNames + atomReceipts <- forM atomNames $ + \(atomgen, _, receiptName, _) -> liftM (BindS (VarP receiptName)) + [|let name = ($atomgen conn) + in internAtom conn $ MkInternAtom False (genericLength name) $ map (fromIntegral . ord) name|] atomInitializers <- forM atomNames $ - \(atomgen, _, varName) -> liftM (BindS (VarP varName)) [| internAtom display ($atomgen display) False |] - - let atomFieldExps = map (\(_, atomName, varName) -> (atomName, VarE varName)) atomNames + \(_, _, receiptName, varName) -> liftM (BindS (VarP varName)) + [|liftM (\(Right a) -> a) $ getReply $(return $ VarE receiptName)|] + + + let atomFieldExps = map (\(_, atomName, _, varName) -> (atomName, VarE varName)) atomNames atomsName = mkName "Atoms" atomsContruction = NoBindS $ AppE (VarE 'return) $ RecConE atomsName atomFieldExps - return $ DoE $ atomInitializers ++ [atomsContruction] + return $ DoE $ atomReceipts ++ atomInitializers ++ [atomsContruction] ) |