summaryrefslogtreecommitdiffstats
path: root/lib/Phi/X11/Atoms.hs
blob: 0a8f66a35708da9865d3b973bc50cdfbb782b8a6 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
{-# LANGUAGE TemplateHaskell #-}

module Phi.X11.Atoms ( Atoms(..)
                     , initAtoms
                     ) where

import Control.Monad
import Data.Char
import Data.List

import Language.Haskell.TH
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
  in return [DataD [] atomsName [] [RecC atomsName fields] []]
 )

initAtoms :: Connection -> IO Atoms
initAtoms conn =
  $(do
       normalAtomNames <- mapM (\atom -> do
                             receiptName <- newName ('_':atom)
                             varName <- newName ('_':atom)
                             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), 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 $
                           \(_, _, 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 $ atomReceipts ++ atomInitializers ++ [atomsContruction]
   )