-----------------------------------------------------------------------------
-- |
-- 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 CPP             #-}
{-# LANGUAGE TemplateHaskell #-}

module Network.XmlRpc.THDeriveXmlRpcType (asXmlRpcStruct) where

import           Control.Monad            (liftM, replicateM)
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 -> Q [Dec]
asXmlRpcStruct Name
name =
    do
    Info
info <- Name -> Q Info
reify Name
name
    Dec
dec <- case Info
info of
                     TyConI Dec
d -> Dec -> Q Dec
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Dec
d
                     Info
_ -> String -> Q Dec
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Dec) -> String -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a. Show a => a -> String
show Name
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not a type constructor"
    Dec -> Q [Dec]
mkInstance Dec
dec

mkInstance :: Dec -> Q [Dec]
#if MIN_VERSION_template_haskell(2,11,0)
mkInstance :: Dec -> Q [Dec]
mkInstance  (DataD Cxt
_ Name
n [TyVarBndr ()]
_ Maybe Kind
_ [RecC Name
c [VarBangType]
fs] [DerivClause]
_) =
#else
mkInstance  (DataD _ n _ [RecC c fs] _) =
#endif
    do
    let ns :: [(Name, Bool)]
ns = ((VarBangType -> (Name, Bool)) -> [VarBangType] -> [(Name, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (\ (Name
f,Bang
_,Kind
t) -> (Name -> Name
unqual Name
f, Kind -> Bool
isMaybe Kind
t)) [VarBangType]
fs)
    [Dec]
tv <- [(Name, Bool)] -> Q [Dec]
mkToValue [(Name, Bool)]
ns
    [Dec]
fv <- Name -> [(Name, Bool)] -> Q [Dec]
mkFromValue Name
c [(Name, Bool)]
ns
    [Dec]
gt <- Q [Dec]
mkGetType
    (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Q Dec -> Q [Dec]) -> Q Dec -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Q Cxt -> Q Kind -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Kind -> [m Dec] -> m Dec
instanceD ([Q Kind] -> Q Cxt
forall (m :: * -> *). Quote m => [m Kind] -> m Cxt
cxt []) (Q Kind -> Q Kind -> Q Kind
forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
appT (Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT ''XmlRpcType)
                                    (Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT Name
n))
              ((Dec -> Q Dec) -> [Dec] -> [Q Dec]
forall a b. (a -> b) -> [a] -> [b]
map Dec -> Q Dec
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> [Q Dec]) -> [Dec] -> [Q Dec]
forall a b. (a -> b) -> a -> b
$ [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]
tv, [Dec]
fv, [Dec]
gt])

mkInstance Dec
_ = String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"Can only derive XML-RPC type for simple record types"


isMaybe :: Type -> Bool
isMaybe :: Kind -> Bool
isMaybe (AppT (ConT Name
n) Kind
_) | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Maybe = Bool
True
isMaybe Kind
_ = Bool
False


unqual :: Name -> Name
unqual :: Name -> Name
unqual = String -> Name
mkName (String -> Name) -> (Name -> String) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char
':',Char
'.']) (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a. Show a => a -> String
show

mkToValue :: [(Name,Bool)] -> Q [Dec]
mkToValue :: [(Name, Bool)] -> Q [Dec]
mkToValue [(Name, Bool)]
fs =
    do
    Name
p <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"p"
    Name -> [PatQ] -> ExpQ -> Q [Dec]
simpleFun 'toValue [Name -> PatQ
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
p]
                (ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'toValue)
                          (ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [| concat |] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ [ExpQ] -> ExpQ
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ ((Name, Bool) -> ExpQ) -> [(Name, Bool)] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> (Name, Bool) -> ExpQ
fieldToTuple Name
p) [(Name, Bool)]
fs))


simpleFun :: Name -> [PatQ] -> ExpQ -> Q [Dec]
simpleFun :: Name -> [PatQ] -> ExpQ -> Q [Dec]
simpleFun Name
n [PatQ]
ps ExpQ
b = [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
n [[PatQ] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [PatQ]
ps (ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB ExpQ
b) []]]

fieldToTuple :: Name -> (Name,Bool) -> ExpQ
fieldToTuple :: Name -> (Name, Bool) -> ExpQ
fieldToTuple Name
p (Name
n,Bool
False) = [ExpQ] -> ExpQ
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE [[ExpQ] -> ExpQ
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
tupE [String -> ExpQ
forall (m :: * -> *). Quote m => String -> m Exp
stringE (Name -> String
forall a. Show a => a -> String
show Name
n),
                                         ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'toValue)
                                         (ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
n) (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
p))
                                        ]
                                 ]
fieldToTuple Name
p (Name
n,Bool
True) =
    [| map (\v -> ($(String -> ExpQ
forall (m :: * -> *). Quote m => String -> m Exp
stringE (Name -> String
forall a. Show a => a -> String
show Name
n)), toValue v)) $ maybeToList $(ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
n) (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
p)) |]

mkFromValue :: Name -> [(Name,Bool)] -> Q [Dec]
mkFromValue :: Name -> [(Name, Bool)] -> Q [Dec]
mkFromValue Name
c [(Name, Bool)]
fs =
    do
    [Name]
names <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([(Name, Bool)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, Bool)]
fs) (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")
    Name
v <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"v"
    Name
t <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"
    Name -> [PatQ] -> ExpQ -> Q [Dec]
simpleFun 'fromValue [Name -> PatQ
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
v] (ExpQ -> Q [Dec]) -> ExpQ -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
               [Q Stmt] -> ExpQ
forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
doE ([Q Stmt] -> ExpQ) -> [Q Stmt] -> ExpQ
forall a b. (a -> b) -> a -> b
$ [PatQ -> ExpQ -> Q Stmt
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Stmt
bindS (Name -> PatQ
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
t) (ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'fromValue) (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v))] [Q Stmt] -> [Q Stmt] -> [Q Stmt]
forall a. [a] -> [a] -> [a]
++
                      (PatQ -> (Name, Bool) -> Q Stmt)
-> [PatQ] -> [(Name, Bool)] -> [Q Stmt]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Name -> PatQ -> (Name, Bool) -> Q Stmt
forall {m :: * -> *} {a}.
(Quote m, Show a) =>
Name -> m Pat -> (a, Bool) -> m Stmt
mkGetField Name
t) ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
names) [(Name, Bool)]
fs [Q Stmt] -> [Q Stmt] -> [Q Stmt]
forall a. [a] -> [a] -> [a]
++
                      [ExpQ -> Q Stmt
forall (m :: * -> *). Quote m => m Exp -> m Stmt
noBindS (ExpQ -> Q Stmt) -> ExpQ -> Q Stmt
forall a b. (a -> b) -> a -> b
$ ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [| return |] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ [ExpQ] -> ExpQ
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
cExpQ -> [ExpQ] -> [ExpQ]
forall a. a -> [a] -> [a]
:(Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
names)]

mkGetField :: Name -> m Pat -> (a, Bool) -> m Stmt
mkGetField Name
t m Pat
p (a
f,Bool
False) = m Pat -> m Exp -> m Stmt
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Stmt
bindS m Pat
p ([m Exp] -> m Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'getField,
                                           String -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (a -> String
forall a. Show a => a -> String
show a
f), Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
t])
mkGetField Name
t m Pat
p (a
f,Bool
True) = m Pat -> m Exp -> m Stmt
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Stmt
bindS m Pat
p ([m Exp] -> m Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE [Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'getFieldMaybe,
                                          String -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (a -> String
forall a. Show a => a -> String
show a
f), Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
t])

mkGetType :: Q [Dec]
mkGetType :: Q [Dec]
mkGetType = Name -> [PatQ] -> ExpQ -> Q [Dec]
simpleFun 'getType [PatQ
forall (m :: * -> *). Quote m => m Pat
wildP]
             (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'TStruct)