diff options
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] + ) |