gistfile1.hs

{-# LANGUAGE TemplateHaskell, QuasiQuotes, NoMonomorphismRestriction #-}
module THUtility where
import Language.Haskell.TH
import Control.Monad
import Data.IORef
import Graphics.UI.Gtk hiding (add)
import Graphics.Rendering.Cairo
import Graphics.UI.Gtk.Gdk.GC
import Graphics.UI.Gtk.Glade
import Control.Applicative
import Control.Arrow

-- GUI型からGUIウィジェット読込コードを生成
castToGUI :: Name -> ExpQ
castToGUI dataName = do
  TyConI (DataD _ _ _ [RecC constructor fieldsData] _) <- reify dataName
  xml <- newName "xml"
  let fields = map (\(a, _, ConT b) -> (nameBase a, mkName $ "castTo" ++ nameBase b)) fieldsData
      binds = map (\(name, castFunc) -> bindS (varP . mkName $ name) (appE (appE (appE (varE 'xmlGetWidget) (varE xml)) (varE castFunc)) (litE (stringL name)))) fields
      ret = noBindS $ appE (varE 'return) $ foldl (\c v -> appE c (varE . mkName . fst $ v)) (conE constructor) fields
  lamE [varP xml] (doE $ binds ++ [ret])