haxr-th (empty) → 3000.0.0

raw patch · 3 files changed

+128/−0 lines, 3 filesdep +basedep +haxrdep +template-haskellbuild-type:Customsetup-changed

Dependencies added: base, haxr, template-haskell

Files

• Network/XmlRpc/THDeriveXmlRpcType.hs +100/−0
• Setup.lhs +8/−0
• haxr-th.cabal +20/−0

@@ -0,0 +1,100 @@+-----------------------------------------------------------------------------+-- |+-- 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)

@@ -0,0 +1,8 @@+#!/usr/bin/env runghc++> module Main where++> import Distribution.Simple++> main :: IO ()+> main = defaultMain

@@ -0,0 +1,20 @@+Name: haxr-th+Version: 3000.0.0+Copyright: Bjorn Bringert, 2003-2006+Build-depends: base, haxr >= 3000.0.0, template-haskell+License: BSD4+License-file: ../LICENSE+Author: Bjorn Bringert <bjorn@bringert.net>+Maintainer: Bjorn Bringert <bjorn@bringert.net>+Homepage: http://www.haskell.org/haxr/+Synopsis: Automatic deriving of XML-RPC structs for Haskell records.+Description:+        HaXR is a library for writing XML-RPC +        client and server applications in Haskell.+        This package adds automatic deriving of+        XML-RPC structs for Haskell records,+        using Template Haskell.+Exposed-Modules:+        Network.XmlRpc.THDeriveXmlRpcType+Extensions: OverlappingInstances, TypeSynonymInstances, TemplateHaskell+GHC-options: -O2