module DBus.QuasiQuoter (
dbus,
dbusF,
) where
import Control.Applicative
import Control.Monad
import qualified Data.Map as Map
import Data.Maybe (fromJust)
import Data.Word
import Data.Int
import qualified DBus
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Text.ParserCombinators.Parsec hiding ((<|>), many)
data DBusFunction = DBusFunction [Type] [Type]
dbus :: QuasiQuoter
dbus = QuasiQuoter
{ quoteExp = expQuoter False
, quotePat = undefined
, quoteType = typeQuoter
, quoteDec = undefined
}
dbusF :: QuasiQuoter
dbusF = QuasiQuoter
{ quoteExp = expQuoter True
, quotePat = undefined
, quoteType = typeQuoter
, quoteDec = undefined
}
expQuoter :: Bool -> String -> Q Exp
expQuoter functor = runQuoter $ \as rs -> do
f <- newName "f"
xs <- mapM newName $ replicate (length as) "x"
result <- thFromVariant functor rs $
VarE f `AppE` ListE (zipWith thToVariant as xs)
return . LamE (VarP f : map VarP xs) $ result
typeQuoter :: String -> Q Type
typeQuoter = runQuoter $ \as rs -> return $ thFunc as rs
runQuoter :: ([Type] -> [Type] -> a) -> String -> a
runQuoter f s = case runParser dbusFunction () "" s of
Left err -> error $ show err
Right (DBusFunction args rets) -> f args rets
dbusFunction :: GenParser Char s DBusFunction
dbusFunction = DBusFunction
<$> (spaces *> dbusTypes <* string "->" <* spaces)
<*> dbusTypes
dbusTypes :: GenParser Char s [Type]
dbusTypes = many $ dbusType <* spaces
dbusType :: GenParser Char s Type
dbusType =
(char 'y' *> return (ConT ''Word8)) <|>
(char 'b' *> return (ConT ''Bool)) <|>
(char 'n' *> return (ConT ''Int16)) <|>
(char 'q' *> return (ConT ''Word16)) <|>
(char 'i' *> return (ConT ''Int32)) <|>
(char 'u' *> return (ConT ''Word32)) <|>
(char 'x' *> return (ConT ''Int64)) <|>
(char 't' *> return (ConT ''Word64)) <|>
(char 'd' *> return (ConT ''Double)) <|>
(char 's' *> return (ConT ''String)) <|>
(char 'o' *> return (ConT ''DBus.ObjectPath)) <|>
(char 'g' *> return (ConT ''DBus.Signature)) <|>
(char 'v' *> return (ConT ''DBus.Variant)) <|>
array <|>
struct
array :: GenParser Char s Type
array = char 'a' *> (assoc <|> simple)
where
assoc = between (char '{') (char '}') $
AppT <$> (AppT (ConT ''Map.Map) <$> dbusType) <*> dbusType
simple = AppT ListT <$> dbusType
struct :: GenParser Char s Type
struct =
between (char '(') (char ')') $ do
types <- many dbusType
return $ thStruct types
thToVariant :: Type -> Name -> Exp
thToVariant t name =
VarE 'DBus.toVariant `AppE` (VarE name `SigE` t)
thFromVariant :: Bool -> [Type] -> Exp -> Q Exp
thFromVariant functor ts expr =
if functor
then [| fmap $(unpack) $(return expr) |]
else [| $(unpack) $(return expr) |]
where
n = length ts
convert t = [| \x -> (fromJust $ DBus.fromVariant x) :: $(return t) |]
apply fs = do
xs <- replicateM n $ newName "x"
return . LamE [TupP (map VarP xs)] . TupE $
zipWith AppE fs (map VarE xs)
unpack = [| $(apply =<< (mapM convert ts)) . $(thTuple n) |]
thStruct :: [Type] -> Type
thStruct ts = foldl AppT (TupleT (length ts)) ts
thTuple :: Int -> ExpQ
thTuple n = do
ns <- replicateM n (newName "x")
lamE [foldr (\x y -> conP '(:) [varP x,y]) wildP ns] (tupE $ map varE ns)
thFunc :: [Type] -> [Type] -> Type
thFunc args rets = foldr arr ret args
where
arr a b = ArrowT `AppT` a `AppT` b
ret = thStruct rets