    -----------------------------------------------------------------------------
    -- |
    -- 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
    name =
        do
        Info
    info <- Name -> Q Info
    reify Name
    name
        Dec
    dec <- case Info
    info of
                         TyConI d :: Dec
    d -> Dec -> Q Dec
    forall (m :: * -> *) a. Monad m => a -> m a
    return Dec
    d
                         _ -> String -> Q Dec
    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]
    ++ " 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 _ n :: Name
    n _ _ [RecC c :: Name
    c fs :: [VarBangType]
    fs] _) =
    #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 (\ (f :: Name
    f,_,t :: Type
    t) -> (Name -> Name
    unqual Name
    f, Type -> Bool
    isMaybe Type
    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
    $ CxtQ -> TypeQ -> [Q Dec] -> Q Dec
    instanceD ([TypeQ] -> CxtQ
    cxt []) (TypeQ -> TypeQ -> TypeQ
    appT (Name -> TypeQ
    conT ''XmlRpcType)
                                        (Name -> TypeQ
    conT Name
    n))
                  ((Dec -> Q Dec) -> [Dec] -> [Q Dec]
    forall a b. (a -> b) -> [a] -> [b]
    map Dec -> Q Dec
    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 _ = String -> Q [Dec]
    forall a. HasCallStack => String -> a
    error "Can only derive XML-RPC type for simple record types"

    isMaybe :: Type -> Bool
    isMaybe :: Type -> Bool
    isMaybe (AppT (ConT n :: Name
    n) _) | Name
    n Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == ''Maybe = Bool
    True
    isMaybe _ = 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` [':','.']) (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 fs :: [(Name, Bool)]
    fs =
        do
        Name
    p <- String -> Q Name
    newName "p"
        Name -> [PatQ] -> ExpQ -> Q [Dec]
    simpleFun 'toValue [Name -> PatQ
    varP Name
    p]
                    (ExpQ -> ExpQ -> ExpQ
    appE (Name -> ExpQ
    varE 'toValue)
                              (ExpQ -> ExpQ -> ExpQ
    appE [| concat |] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
    forall a b. (a -> b) -> a -> b
    $ [ExpQ] -> ExpQ
    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 n :: Name
    n ps :: [PatQ]
    ps b :: ExpQ
    b = [Q Dec] -> Q [Dec]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    sequence [Name -> [ClauseQ] -> Q Dec
    funD Name
    n [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
    clause [PatQ]
    ps (ExpQ -> BodyQ
    normalB ExpQ
    b) []]]

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

    mkFromValue :: Name -> [(Name,Bool)] -> Q [Dec]
    mkFromValue :: Name -> [(Name, Bool)] -> Q [Dec]
    mkFromValue c :: Name
    c fs :: [(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 (t :: * -> *) a. Foldable t => t a -> Int
    length [(Name, Bool)]
    fs) (String -> Q Name
    newName "x")
        Name
    v <- String -> Q Name
    newName "v"
        Name
    t <- String -> Q Name
    newName "t"
        Name -> [PatQ] -> ExpQ -> Q [Dec]
    simpleFun 'fromValue [Name -> PatQ
    varP Name
    v] (ExpQ -> Q [Dec]) -> ExpQ -> Q [Dec]
    forall a b. (a -> b) -> a -> b
    $
                   [StmtQ] -> ExpQ
    doE ([StmtQ] -> ExpQ) -> [StmtQ] -> ExpQ
    forall a b. (a -> b) -> a -> b
    $ [PatQ -> ExpQ -> StmtQ
    bindS (Name -> PatQ
    varP Name
    t) (ExpQ -> ExpQ -> ExpQ
    appE (Name -> ExpQ
    varE 'fromValue) (Name -> ExpQ
    varE Name
    v))] [StmtQ] -> [StmtQ] -> [StmtQ]
    forall a. [a] -> [a] -> [a]
    ++
                          (PatQ -> (Name, Bool) -> StmtQ)
    -> [PatQ] -> [(Name, Bool)] -> [StmtQ]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith (Name -> PatQ -> (Name, Bool) -> StmtQ
    forall a. Show a => Name -> PatQ -> (a, Bool) -> StmtQ
    mkGetField Name
    t) ((Name -> PatQ) -> [Name] -> [PatQ]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> PatQ
    varP [Name]
    names) [(Name, Bool)]
    fs [StmtQ] -> [StmtQ] -> [StmtQ]
    forall a. [a] -> [a] -> [a]
    ++
                          [ExpQ -> StmtQ
    noBindS (ExpQ -> StmtQ) -> ExpQ -> StmtQ
    forall a b. (a -> b) -> a -> b
    $ ExpQ -> ExpQ -> ExpQ
    appE [| return |] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
    forall a b. (a -> b) -> a -> b
    $ [ExpQ] -> ExpQ
    appsE (Name -> ExpQ
    conE Name
    cExpQ -> [ExpQ] -> [ExpQ]
    forall a. a -> [a] -> [a]
    :(Name -> ExpQ) -> [Name] -> [ExpQ]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> ExpQ
    varE [Name]
    names)]

    mkGetField :: Name -> PatQ -> (a, Bool) -> StmtQ
    mkGetField t :: Name
    t p :: PatQ
    p (f :: a
    f,False) = PatQ -> ExpQ -> StmtQ
    bindS PatQ
    p ([ExpQ] -> ExpQ
    appsE [Name -> ExpQ
    varE 'getField,
                                               String -> ExpQ
    stringE (a -> String
    forall a. Show a => a -> String
    show a
    f), Name -> ExpQ
    varE Name
    t])
    mkGetField t :: Name
    t p :: PatQ
    p (f :: a
    f,True) = PatQ -> ExpQ -> StmtQ
    bindS PatQ
    p ([ExpQ] -> ExpQ
    appsE [Name -> ExpQ
    varE 'getFieldMaybe,
                                              String -> ExpQ
    stringE (a -> String
    forall a. Show a => a -> String
    show a
    f), Name -> ExpQ
    varE Name
    t])

    mkGetType :: Q [Dec]
    mkGetType :: Q [Dec]
    mkGetType = Name -> [PatQ] -> ExpQ -> Q [Dec]
    simpleFun 'getType [PatQ
    wildP]
                 (Name -> ExpQ
    conE 'TStruct)