Alright... I *think* I'm nearly there, but I can't figure out how to derive a class instance using record accessors and updaters... Can anyone help? There are [| XXXf |] instances at the end of the module and they all need replaced, but I can't figure out what to replace them with. The basic idea of the module is that you define your record type, Q, and that record type contains all the state you're interested in. The Hieroglyph system has other basic state, and the idea is that you use
$(additions "QWithState" ''Q) $(deriveUIState ''QWithState) to create your final UIState instance. -- - {-# LANGUAGE TemplateHaskell #-} module Graphics.Rendering.Hieroglyph.TH where import Language.Haskell.TH import Language.Haskell.TH.Syntax import Graphics.Rendering.Hieroglyph.UIState import Graphics.Rendering.Hieroglyph.Primitives import Graphics.UI.Gtk.Types (Widget) import Control.Monad {- output of $( fmap (LitE . StringL . show) [| reify ''BasicUIState |] ) TyConI (DataD [] Graphics.Rendering.Hieroglyph.BasicUIState.BasicUIState [] [RecC Graphics.Rendering.Hieroglyph.BasicUIState.BasicUIState [(Graphics.Rendering.Hieroglyph.BasicUIState.mousePosition,NotStrict,ConT Graphics.Rendering.Hieroglyph.Primitives.Point) ,(Graphics.Rendering.Hieroglyph.BasicUIState.mouseLeftButtonDown,NotStrict,ConT GHC.Base.Bool) ,(Graphics.Rendering.Hieroglyph.BasicUIState.mouseRightButtonDown,NotStrict,ConT GHC.Base.Bool) ,(Graphics.Rendering.Hieroglyph.BasicUIState.mouseMiddleButtonDown,NotStrict,ConT GHC.Base.Bool) ,(Graphics.Rendering.Hieroglyph.BasicUIState.mouseWheel,NotStrict,ConT GHC.Base.Int) ,(Graphics.Rendering.Hieroglyph.BasicUIState.keyCtrl,NotStrict,ConT GHC.Base.Bool) ,(Graphics.Rendering.Hieroglyph.BasicUIState.keyShift,NotStrict,ConT GHC.Base.Bool) ,(Graphics.Rendering.Hieroglyph.BasicUIState.keyAlt,NotStrict,ConT GHC.Base.Bool) ,(Graphics.Rendering.Hieroglyph.BasicUIState.key,NotStrict,ConT Graphics.Rendering.Hieroglyph.UIState.Key) ,(Graphics.Rendering.Hieroglyph.BasicUIState.drawing,NotStrict,AppT (ConT Data.Maybe.Maybe) (ConT Graphics.UI.Gtk.Types.Widget)) ,(Graphics.Rendering.Hieroglyph.BasicUIState.sizeX,NotStrict,ConT GHC.Float.Double) ,(Graphics.Rendering.Hieroglyph.BasicUIState.sizeY,NotStrict,ConT GHC.Float.Double) ,(Graphics.Rendering.Hieroglyph.BasicUIState.imageCache,NotStrict,AppT (ConT Data.Maybe.Maybe) (ConT Graphics.Rendering.Hieroglyph.UIState.ImageCache))]] []) -} -- usage: $(additions "MyTypeName" OldTypeName) {- - Add fields to a record type for handling basic UI state for Hieroglyph. Gives you mouse buttons, etcetera -} additions newtypenamestr nm = do TyConI (DataD _ _ _ [RecC _ fielddefs]) <- reify nm let newtypename = mkName newtypenamestr return $ (DataD [] newtypename [] [RecC newtypename [(mkName "mousePositionf",NotStrict,ConT ''Point) ,(mkName "mouseLeftButtonDownf",NotStrict,ConT ''Bool) ,(mkName "mouseRightButtonDownf",NotStrict,ConT ''Bool) ,(mkName "mouseMiddleButtonDownf",NotStrict,ConT ''Bool) ,(mkName "mouseWheelf",NotStrict,ConT ''Int) ,(mkName "keyCtrlf",NotStrict,ConT ''Bool) ,(mkName "keyShiftf",NotStrict,ConT ''Bool) ,(mkName "keyAltf",NotStrict,ConT ''Bool) ,(mkName "keyf",NotStrict,ConT ''Key) ,(mkName "drawingf",NotStrict,AppT (ConT ''Maybe) (ConT ''Widget)) ,(mkName "sizeXf",NotStrict,ConT ''Double) ,(mkName "sizeYf",NotStrict,ConT ''Double) ,(mkName "imageCachef",NotStrict,AppT (ConT ''Maybe) (ConT ''ImageCache))] ++ fielddefs] []) -- | Apply a Binary type constructor to given type: "t" -> "Binary t" appUIState :: Type -> Type appUIState t = AppT (ConT ''UIState) t -- | Generate from list of type names result of types application: -- appType T [a,b] -> "T a b" appType :: Name -> [Name] -> Type --appType t [] = ConT t -- T --appType t [t1] = AppT (ConT t) (VarT t1) -- T a --appType t [t1,t2] = AppT (AppT (ConT t) (VarT t1)) (VarT t2) -- T a b == (T a) b appType t ts = foldl (\a e -> AppT a (VarT e)) (ConT t) ts -- general definition -- | Generate `n` unique variables and return them in form of patterns and expressions genNames :: Int -> Q ([PatQ],[ExpQ]) genNames n = do ids <- replicateM n (newName "x") return (map varP ids, map varE ids) -- usage: $(deriveUIState ''MyTypeWithUIState) {- - Derive an instance of UIState from some type that has had UIState fields added to it. -} deriveUIState tp = do return [InstanceD [] (appUIState $ appType tp []) [FunD 'mousePosition [| mousePositionf |] ,FunD 'mouseLeftButtonDown [| mouseLeftButtonDownf |] ,FunD 'mouseRightButtonDown [| mouseRightButtonDownf |] ,FunD 'mouseMiddleButtonDown [| mouseMiddleButtonDownf |] ,FunD 'mouseWheel [| mouseWheelf |] ,FunD 'keyCtrl [| keyCtrlf |] ,FunD 'keyShift [| keyShiftf |] ,FunD 'keyAlt [| keyAltf |] ,FunD 'key [| keyf |] ,FunD 'drawing [| drawingf |] ,FunD 'sizeX [| sizeXf |] ,FunD 'sizeY [| sizeYf |] ,FunD 'imageCache [| imageCachef |] ,FunD 'setMousePosition [| \b a -> a{ mousePositionf=b } |] ,FunD 'setMouseLeftButtonDown [| \b a -> a{ mouseLeftButtonDownf=b } |] ,FunD 'setMouseRightButtonDown [| \b a -> a{ mouseRightButtonDownf=b } |] ,FunD 'setMouseMiddleButtonDown [| \b a -> a{ mouseMiddleButtonDownf=b } |] ,FunD 'setMouseWheel [| \b a -> a{ mouseWheelf=b } |] ,FunD 'setKeyCtrl [| \b a -> a{ keyCtrlf=b } |] ,FunD 'setKeyShift [| \b a -> a{ keyShiftf=b } |] ,FunD 'setKeyAlt [| \b a -> a{ keyAltf=b } |] ,FunD 'setKey [| \b a -> a{ keyf=b } |] ,FunD 'setDrawing [| \b a -> a{ drawingf=b } |] ,FunD 'setSizeX [| \b a -> a{ sizeXf=b } |] ,FunD 'setSizeY [| \b a -> a{ sizeYf=b } |] ,FunD 'setImageCache] [| \b a -> a{ imageCachef=b } |] ] _______________________________________________ Haskell-Cafe mailing list Haskell-Cafe@haskell.org http://www.haskell.org/mailman/listinfo/haskell-cafe