[Haskell-cafe] Template Haskell question

[Jeff Heard]

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 } |]
                      ]