blob: a2708dd47b8add5e64c280d23f912cb2d74644a8 (
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
|
{-# LANGUAGE TemplateHaskell #-}
module Phi.X11.Atoms ( Atoms(..)
, initAtoms
) where
import Control.Monad
import Language.Haskell.TH
import Graphics.X11
import Phi.X11.AtomList
$(do
let atomsName = mkName "Atoms"
atomNames = map (\atom -> (atom, mkName ("atom" ++ atom))) atoms
fields = map (\(_, name) -> (name, IsStrict, ConT ''Atom)) atomNames
return [DataD [] atomsName [] [RecC atomsName fields] []]
)
initAtoms :: Display -> IO Atoms
initAtoms display =
$(do
let atomsName = mkName "Atoms"
atomNames <- mapM (\atom -> do
varName <- newName ('_':atom)
return (atom, mkName ("atom" ++ atom), varName)
) atoms
atomInitializers <- forM atomNames $
\(atom, _, varName) -> liftM (BindS (VarP varName)) [| internAtom display atom False |]
let atomFieldExps = map (\(_, atomName, varName) -> (atomName, VarE varName)) atomNames
atomsContruction = NoBindS $ AppE (VarE 'return) $ RecConE atomsName atomFieldExps
return $ DoE $ atomInitializers ++ [atomsContruction]
)
|
