{-# LANGUAGE TemplateHaskell #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.UI.Gtk.Glade.Accessor
-- Copyright   :  (c) Yakov Zaytsev 2009
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  yakov@yakov.cc
-- Stability   :  experimental
-- Portability :  non-portable (TH)
--

-----------------------------------------------------------------------------

module Graphics.UI.Gtk.Glade.Accessor (
    importGladeXml
  ) where

import Text.XML.HaXml.Wrappers
import Text.XML.HaXml.Parse
import Text.XML.HaXml.Combinators
import Text.XML.HaXml.XmlContent
import Text.XML.HaXml.OneOfN
import Language.Haskell.TH
import Graphics.UI.Gtk.Glade (xmlGetWidget)

import Graphics.UI.Gtk.Glade.Glade20DTD

importGladeXml :: FilePath -> Q [Dec]
importGladeXml fp = do wcs <- runIO widgetIdsAndClasses
                       mapM (uncurry mkAccessor) wcs
    where
        mkAccessor id ('G':'t':'k':clas)
            = funD (mkName id)
                   [clause [varP (mkName "xml")]
                           (normalB $ [| xmlGetWidget $(varE $ mkName "xml")
                                                      $(varE $ mkName
                                                      $ "castTo" ++ clas) id |])
                           []]

        widgetIdsAndClasses = do cs <- readFile fp
                                 case readXml cs of
                                   Right d -> return $ widgetIdClass d
                                   _ -> return []

        widgetIdClass :: Glade_interface -> [(String, String)]
        widgetIdClass (Glade_interface _ _ ws) = concat $ map goWidget ws

        goWidget :: Widget -> [(String, String)]
        goWidget (Widget (Widget_Attrs { widgetClass = wc, widgetId = wid }) _ _ _ _ ch)
            = ((wid, wc):(concat $ map goChild ch))

        goChild (Child _ (OneOf2 widget) _) = goWidget widget
        goChild (Child _ _ _) = []