40 lines
1.5 KiB
Haskell
40 lines
1.5 KiB
Haskell
{-# LANGUAGE TemplateHaskell #-}
|
|
|
|
module Phi.X11.Atoms ( Atoms(..)
|
|
, initAtoms
|
|
) where
|
|
|
|
import Control.Monad
|
|
import Language.Haskell.TH
|
|
import Graphics.X11
|
|
|
|
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 :: Display -> IO Atoms
|
|
initAtoms display =
|
|
$(do
|
|
normalAtomNames <- mapM (\atom -> do
|
|
varName <- newName ('_':atom)
|
|
return ([|const atom|], mkName ("atom" ++ atom), varName)
|
|
) atoms
|
|
specialAtomNames <- mapM (\(name, atomgen) -> do
|
|
varName <- newName ('_':name)
|
|
return (atomgen, mkName ("atom" ++ name), varName)
|
|
) specialAtoms
|
|
let atomNames = normalAtomNames ++ specialAtomNames
|
|
atomInitializers <- forM atomNames $
|
|
\(atomgen, _, varName) -> liftM (BindS (VarP varName)) [| internAtom display ($atomgen display) False |]
|
|
|
|
let atomFieldExps = map (\(_, atomName, varName) -> (atomName, VarE varName)) atomNames
|
|
atomsName = mkName "Atoms"
|
|
atomsContruction = NoBindS $ AppE (VarE 'return) $ RecConE atomsName atomFieldExps
|
|
|
|
return $ DoE $ atomInitializers ++ [atomsContruction]
|
|
)
|