module Manatee.Core.TH where
import Control.Applicative
import Control.Monad
import DBus.Types
import Language.Haskell.TH
unpackVariantList :: Name -> Name -> ExpQ
unpackVariantList tagt dty = do
let getCons (TyConI (DataD _ _ _ x _)) = [ (n,length ts) | NormalC n ts <- x ]
tags <- (map fst . getCons) `fmap` reify tagt
dats <- getCons `fmap` reify dty
[| \tag ls ->
$( caseE [| (tag,ls) |]
[do
xs <- replicateM n (newName "x")
match
(tupP [recP t [],listP (map varP xs)])
(normalB $ foldl
(\f x -> [| $f <*> $x |])
[| pure $(conE d) |]
(map (\x -> [| fromVariant $(varE x) |] ) xs))
[]
| (t,(d,n)) <- tags `zip` dats ]
)
|]
signalArgsTemplate :: String
signalArgsTemplate = "Args"
checkSignalArgs :: Name -> Name -> ExpQ
checkSignalArgs tagt dty = do
let getCons (TyConI (DataD _ _ _ x _)) = [ (n, ts) | NormalC n ts <- x ]
tags <- (map fst . getCons) `fmap` reify tagt
dats <- (map fst . getCons) `fmap` reify dty
[| \tag ls ->
$( caseE [| (tag,ls) |]
[do
let memberName = nameBase t ++ signalArgsTemplate
signalArgsName = nameBase d
match
(tupP [recP t [], recP d []])
(normalB [| memberName == signalArgsName |])
[]
| (t,d) <- tags `zip` dats ]
)
|]
packVariantList :: String -> Name -> Q [Dec]
packVariantList = packListTemplate (\x -> [| toVariant $(varE x) |])
packStringList :: String -> Name -> Q [Dec]
packStringList = packListTemplate (\x -> [| show $(varE x) |])
packListTemplate :: (Name -> ExpQ) -> String -> Name -> Q [Dec]
packListTemplate fun str args = do
TyConI (DataD _ _ _ constructors _) <- reify args
let packList (NormalC name fields) = do
vars <- replicateM (length fields) (newName "x")
let pats = map varP vars
clause [conP name pats]
(normalB (listE $ map fun vars))
[]
body <- forM constructors (return . packList)
fmap (: []) $ funD (mkName str) body
mkDec :: String -> ExpQ -> DecQ
mkDec str f = funD (mkName str) [clause [] (normalB f) []]
mkFunDec :: String -> ExpQ -> Q [Dec]
mkFunDec str f = fmap (: []) $ mkDec str f
genPE fields = do
ids <- replicateM (length fields) (newName "x")
return (map varP ids, map varE ids)
deriveVariable _t = [d|
instance Variable $_t where
toVariant = toVariant . show
fromVariant x = fmap (\v -> read v :: $_t) $ fromVariant x|]