    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Network.XmlRpc.THDeriveXmlRpcType
    -- Copyright   :  (c) Bjorn Bringert 2003-2005
    -- License     :  BSD-style
    --
    -- Maintainer  :  bjorn@bringert.net
    -- Stability   :  experimental
    -- Portability :  non-portable (requires extensions and non-portable libraries)
    --
    -- Uses Template Haskell to automagically derive instances of 'XmlRpcType'
    --
    ------------------------------------------------------------------------------

    {-# LANGUAGE TemplateHaskell #-}
    module Network.XmlRpc.THDeriveXmlRpcType (asXmlRpcStruct) where

    import Control.Monad (replicateM, liftM)
    import Data.List (genericLength)
    import Data.Maybe (maybeToList)
    import Language.Haskell.TH
    import Network.XmlRpc.Internals hiding (Type)

    -- | Creates an 'XmlRpcType' instance which handles a Haskell record
    --   as an XmlRpc struct. Example:
    -- @
    -- data Person = Person { name :: String, age :: Int }
    -- $(asXmlRpcStruct \'\'Person)
    -- @
    asXmlRpcStruct :: Name -> Q [Dec]
    asXmlRpcStruct name =
        do
        info <- reify name
        dec <- case info of
    		     TyConI d -> return d
    		     _ -> fail $ show name ++ " is not a type constructor"
        mkInstance dec

    mkInstance :: Dec -> Q [Dec]
    mkInstance  (DataD _ n _ [RecC c fs] _) =
        do
        let ns = (map (\ (f,_,t) -> (unqual f, isMaybe t)) fs)
        tv <- mkToValue ns
        fv <- mkFromValue c ns
        gt <- mkGetType
        liftM (:[]) $ instanceD (cxt []) (appT (conT ''XmlRpcType)
    				    (conT n))
    	      (map return $ concat [tv, fv, gt])

    mkInstance _ = error "Can only derive XML-RPC type for simple record types"

    isMaybe :: Type -> Bool
    isMaybe (AppT (ConT n) _) | n == ''Maybe = True
    isMaybe _ = False

    unqual :: Name -> Name
    unqual = mkName . reverse . takeWhile (`notElem` [':','.']) . reverse . show

    mkToValue :: [(Name,Bool)] -> Q [Dec]
    mkToValue fs =
        do
        p <- newName "p"
        simpleFun 'toValue [varP p]
    		(appE (varE 'toValue)
    			  (appE [| concat |] $ listE $ map (fieldToTuple p) fs))

    simpleFun :: Name -> [PatQ] -> ExpQ -> Q [Dec]
    simpleFun n ps b = sequence [funD n [clause ps (normalB b) []]]

    fieldToTuple :: Name -> (Name,Bool) -> ExpQ
    fieldToTuple p (n,False) = listE [tupE [stringE (show n),
    					 appE (varE 'toValue)
    					 (appE (varE n) (varE p))
    					]
    				 ]
    fieldToTuple p (n,True) =
        [| map (\v -> ($(stringE (show n)), toValue v)) $ maybeToList $(appE (varE n) (varE p)) |]

    mkFromValue :: Name -> [(Name,Bool)] -> Q [Dec]
    mkFromValue c fs =
        do
        names <- replicateM (length fs) (newName "x")
        v <- newName "v"
        t <- newName "t"
        simpleFun 'fromValue [varP v] $
    	       doE $ [bindS (varP t) (appE (varE 'fromValue) (varE v))] ++
    		      zipWith (mkGetField t) (map varP names) fs ++
    		      [noBindS $ appE [| return |] $ appsE (conE c:map varE names)]

    mkGetField t p (f,False) = bindS p (appsE [varE 'getField,
    					   stringE (show f), varE t])
    mkGetField t p (f,True) = bindS p (appsE [varE 'getFieldMaybe,
    					  stringE (show f), varE t])

    mkGetType :: Q [Dec]
    mkGetType = simpleFun 'getType [wildP]
    	     (conE 'TStruct)