diff options
author | Matthias Schiffer <mschiffer@universe-factory.net> | 2011-07-12 19:09:05 +0200 |
---|---|---|
committer | Matthias Schiffer <mschiffer@universe-factory.net> | 2011-07-12 19:09:05 +0200 |
commit | 982bcffcfeb074b4c1beff64ca7361a9a66ed273 (patch) | |
tree | 176299794f94b55ed0d8c7b83ed2c54ef468b129 /lib/Phi/X11/Atoms.hs | |
parent | 19378fdcf11af2ef78d1b7e6cbda06952bb4e692 (diff) | |
download | phi-982bcffcfeb074b4c1beff64ca7361a9a66ed273.tar phi-982bcffcfeb074b4c1beff64ca7361a9a66ed273.zip |
Preload atoms using template haskell
Diffstat (limited to 'lib/Phi/X11/Atoms.hs')
-rw-r--r-- | lib/Phi/X11/Atoms.hs | 36 |
1 files changed, 36 insertions, 0 deletions
diff --git a/lib/Phi/X11/Atoms.hs b/lib/Phi/X11/Atoms.hs new file mode 100644 index 0000000..a2708dd --- /dev/null +++ b/lib/Phi/X11/Atoms.hs @@ -0,0 +1,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] + ) |