packages feed

dbus-qq (empty) → 0.0.1

raw patch · 5 files changed

+262/−0 lines, 5 filesdep +basedep +containersdep +dbus-coresetup-changed

Dependencies added: base, containers, dbus-core, parsec, template-haskell

Files

+ DBus/QuasiQuoter.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}++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.Types as DT+import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Text.ParserCombinators.Parsec hiding ((<|>), many)++data DBusFunction = DBusFunction [Type] [Type]++-- |A quasi-quoter to convert a function of type @[Variant] -> [Variant]@ into a+-- function of a specified static type.+--+-- This quasi-quoter takes a signature of the form:+--+-- @+--   \<dbus types\> -> \<dbus types\>+-- @+--+-- Types on the left of the arrow correspond to argument types, while those on+-- the right are return types.+--+-- The result is a combinator which takes any function of type [Variant] ->+-- [Variant], assumes that its arguments and results are of the specified+-- number and types, and returns a function of the corresponding static type.+--+-- For example, if @f :: [Variant] -> [Variant]@,+--+-- @+--   [dbus| i s -> s a{uv} |] f+-- @+--+-- has type+--+-- @+--   Int -> String -> (String, Map Word32 Variant)+-- @+dbus :: QuasiQuoter+dbus = QuasiQuoter+  { quoteExp = expQuoter False+  , quotePat = undefined+  , quoteType = typeQuoter+  , quoteDec = undefined+  }++-- |A generalized version of the dbus quasi-quoter which works on functions of+-- type @[Variant] -> f [Variant]@, for any functor @f@.+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+  <$> (space *> 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 ''DT.ObjectPath)) <|>+  (char 'g' *> return (ConT ''DT.Signature)) <|>+  (char 'v' *> return (ConT ''DT.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 'DT.toVariant `AppE` (VarE name `SigE` t)++thFromVariant :: Bool -> [Type] -> Exp -> Q Exp+thFromVariant functor ts exp =+  if functor+    then [| fmap $(unpack) $(return exp) |]+    else [| $(unpack) $(return exp) |]+  where+    n = length ts+    convert t = [| \x -> (fromJust $ DT.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
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2012, Paolo Capriotti++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Paolo Capriotti nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Tests.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}++import DBus.QuasiQuoter+import DBus.Types+import Data.Int+import qualified Data.Map as Map+import Data.Maybe+import Data.Word+import Test.QuickCheck+import Text.Printf++main :: IO ()+main  = mapM_ (\(s,a) -> printf "%-25s: " s >> a) tests++prop_simple x y = show (x + y) == [dbus| i i -> s |] f x y+  where+    f :: [Variant] -> [Variant]+    f xs = [toVariant . show . sum $ (map (fromJust . fromVariant) xs :: [Int32])]++prop_functor x y = Just (show (x + y)) == [dbusF| i i -> s |] f x y+  where+    f :: [Variant] -> Maybe [Variant]+    f xs = Just [toVariant . show . sum $ (map (fromJust . fromVariant) xs :: [Int32])]++prop_maps = Map.empty == [dbus| a{su} -> a{on} |] f Map.empty+  where+    f :: [Variant] -> [Variant]+    f _ = [toVariant (Map.empty :: Map.Map ObjectPath Int16)]++prop_tuples x y = show x ++ y == [dbus| (is) -> s |] f (x, y)+  where+    f :: [Variant] -> [Variant]+    f [x] =+      let (n, s) = fromJust (fromVariant x) :: (Int32, String)+      in [toVariant $ show n ++ s]++prop_retvals x = (x, x) == [dbus| i -> ii |] f x+  where+    f :: [Variant] -> [Variant]+    f [x] = [x, x]++prop_values x = x * 2 == [dbus| -> i |] f+  where+    f :: [Variant] -> [Variant]+    f _ = [toVariant (x * 2)]++prop_unit x = () == [dbus| s -> |] f x+  where+    f :: [Variant] -> [Variant]+    f _ = []++tests = [("simple", quickCheck prop_simple)+        ,("functor", quickCheck prop_functor)+        ,("maps", quickCheck prop_maps)+        ,("tuples", quickCheck prop_tuples)+        ,("retvals", quickCheck prop_retvals)+        ,("values", quickCheck prop_values)+        ,("unit", quickCheck prop_unit)]
+ dbus-qq.cabal view
@@ -0,0 +1,21 @@+Name: dbus-qq+Version: 0.0.1+Synopsis: Quasi-quoter for DBus functions+Description: This package contains a quasi-quoter to automatically convert functions of the form @[Variant] -> [Variant]@ to functions of the actual types, returning a tuple of the results.+License: BSD3+License-file: LICENSE+Author: Paolo Capriotti+Maintainer: p.capriotti@gmail.com+Category: Network+Build-type: Simple+Cabal-version: >=1.8+Extra-source-files: Tests.hs++Library+    Exposed-modules: DBus.QuasiQuoter+    Build-depends: base (== 4.*), parsec (== 3.1.*), dbus-core (== 0.9.*), template-haskell, containers (< 0.5)+    Extensions: TemplateHaskell, QuasiQuotes++Source-repository head+    type: git+    location: git://github.com/pcapriotti/dbus-qq.git