From f5bd97ea284a7617584cde72dcbc59f4c205244b Mon Sep 17 00:00:00 2001 From: Ilya Portnov Date: Sat, 5 Jun 2010 20:00:38 +0600 Subject: [PATCH] Remove dependence from convertible-text. --- Network/YAML/Base.hs | 8 ++- Network/YAML/Caller.hs | 5 +- Network/YAML/Derive.hs | 14 ++--- Network/YAML/Dispatcher.hs | 3 +- Network/YAML/Instances.hs | 126 +++++++++++++++---------------------------- Test.hs | 1 - TestCall.hs | 1 - TestDerive.hs | 1 - yaml-rpc.cabal | 2 +- 9 files changed, 59 insertions(+), 102 deletions(-) diff --git a/Network/YAML/Base.hs b/Network/YAML/Base.hs index dd762ae..ed9b812 100644 --- a/Network/YAML/Base.hs +++ b/Network/YAML/Base.hs @@ -12,7 +12,9 @@ import Text.Libyaml hiding (encode, decode) type HostAndPort = (BS.ByteString, Int) -class (ConvertSuccess YamlObject a, ConvertSuccess a YamlObject, Default a) => IsYamlObject a where +class (Default a) => IsYamlObject a where + toYaml :: a -> YamlObject + fromYaml :: YamlObject -> a getAttr :: BS.ByteString -> YamlObject -> Maybe YamlObject getAttr key (Mapping pairs) = lookup (toYamlScalar key) pairs @@ -69,12 +71,12 @@ instance IsYamlScalar Integer where serialize :: IsYamlObject a => a -> BS.ByteString serialize x = let c :: YamlObject - c = cs x + c = toYaml x in encode c unserialize :: IsYamlObject a => BS.ByteString -> Maybe a unserialize x = let d :: Maybe YamlObject d = decode x - in cs `fmap` d + in fromYaml `fmap` d diff --git a/Network/YAML/Caller.hs b/Network/YAML/Caller.hs index dcaad0c..16b91f0 100644 --- a/Network/YAML/Caller.hs +++ b/Network/YAML/Caller.hs @@ -4,7 +4,6 @@ module Network.YAML.Caller where import qualified Data.Map as M import Data.Object.Yaml -import Data.Convertible.Base import qualified Data.ByteString.Char8 as BS import Network import System.IO @@ -57,7 +56,7 @@ instance Connection HostAndPort where -- -> a -- ^ Argument for method -- -> IO b call (host,port) name args = do - let c = mkCall name (cs args) + let c = mkCall name (toYaml args) s = serialize c text <- sendYAML (host,port) s case unserialize text of @@ -77,7 +76,7 @@ instance Connection PersistentConnection where closeConnection (PC h) = hClose h call (PC h) name args = do - let c = mkCall name (cs args) + let c = mkCall name (toYaml args) s = serialize c text <- hSendYAML h s case unserialize text of diff --git a/Network/YAML/Derive.hs b/Network/YAML/Derive.hs index 948005c..641c1c6 100644 --- a/Network/YAML/Derive.hs +++ b/Network/YAML/Derive.hs @@ -21,7 +21,7 @@ mkList (v:vars) = [| (toYamlScalar $(stringOfName v), Scalar $ toYamlScalar $(va mkSeq :: [Name] -> ExpQ mkSeq [] = [| [] |] -mkSeq (v:vars) = [| cs $(varE v): $(mkSeq vars) |] +mkSeq (v:vars) = [| toYaml $(varE v): $(mkSeq vars) |] getNameBase :: Name -> Name getNameBase name = mkName $ nameBase name @@ -75,32 +75,30 @@ fromClause (NormalC name fields) = do body = foldl appE (conE $ mkName cName) $ map (getAttr' cName obj) $ map fst (zip [0..] names) clause [varP obj] (guardedB [normalGE guard body]) [] where - getAttr' c obj k = [| cs $ getItem (BS.pack c) k $(varE obj) |] + getAttr' c obj k = [| fromYaml $ getItem (BS.pack c) k $(varE obj) |] getName (n,x) = (n, getNameBase x) --- | Derive `instance ConvertSuccess t YamlObject ...' deriveToYamlObject :: Name -> Q [Dec] deriveToYamlObject t = do -- Get list of constructors for type t TyConI (DataD _ _ _ constructors _) <- reify t convbody <- mapM consClause constructors - return [InstanceD [] (ConT ''ConvertSuccess `AppT` ConT t `AppT` ConT ''YamlObject) [FunD 'convertSuccess convbody]] + return [FunD 'toYaml convbody] --- | Derive `instance ConvertSuccess YamlObject t ...' deriveFromYamlObject :: Name -> Q [Dec] deriveFromYamlObject t = do TyConI (DataD _ _ _ constructors _) <- reify t body <- mapM fromClause constructors - return [InstanceD [] (ConT ''ConvertSuccess `AppT` ConT ''YamlObject `AppT` ConT t) [FunD 'convertSuccess body]] + return [FunD 'fromYaml body] -- | Derive `instance IsYamlObject t where ...' deriveIsYamlObject :: Name -> Q [Dec] deriveIsYamlObject t = do [i1] <- deriveToYamlObject t [i2] <- deriveFromYamlObject t - let i3 = InstanceD [] (ConT ''IsYamlObject `AppT` ConT t) [] - return [i1,i2,i3] + let res = InstanceD [] (ConT ''IsYamlObject `AppT` ConT t) [i1, i2] + return [res] defaultClause :: Con -> ClauseQ defaultClause (RecC name fields) = do diff --git a/Network/YAML/Dispatcher.hs b/Network/YAML/Dispatcher.hs index 4af6763..7cc8e13 100644 --- a/Network/YAML/Dispatcher.hs +++ b/Network/YAML/Dispatcher.hs @@ -3,7 +3,6 @@ module Network.YAML.Dispatcher where import qualified Data.Map as M import Data.Object.Yaml -import Data.Convertible.Base import qualified Data.ByteString.Char8 as BS import Network.YAML.Base @@ -21,7 +20,7 @@ mkRules pairs = M.fromList pairs dispatch :: Rules -> Worker dispatch rules = \obj -> let call :: Call - call = cs obj + call = fromYaml obj in case M.lookup (methodName call) rules of Nothing -> fail $ "Unknown method: " ++ (BS.unpack $ methodName call) Just fn -> fn (args call) diff --git a/Network/YAML/Instances.hs b/Network/YAML/Instances.hs index 2b654b3..d71b5e8 100644 --- a/Network/YAML/Instances.hs +++ b/Network/YAML/Instances.hs @@ -21,46 +21,37 @@ field name val = Mapping [(toYamlScalar name, Scalar $ toYamlScalar val)] instance Default BS.ByteString where def = BS.empty -instance (IsYamlObject a) => ConvertSuccess [a] YamlObject where - convertSuccess lst = Sequence $ map cs lst - -instance (IsYamlObject a) => ConvertSuccess YamlObject [a] where - convertSuccess (Mapping pairs) = map cs $ map snd pairs - convertSuccess (Sequence lst) = map cs lst - convertSuccess s@(Scalar _) = [cs s] - instance (IsYamlObject a) => IsYamlObject [a] where + toYaml lst = Sequence $ map toYaml lst + + fromYaml (Mapping pairs) = map fromYaml $ map snd pairs + fromYaml (Sequence lst) = map fromYaml lst + fromYaml s@(Scalar _) = [fromYaml s] tryGet lst k = if k >= length lst then def else lst !! k -instance (IsYamlObject a, IsYamlObject b) => ConvertSuccess (a,b) YamlObject where - convertSuccess (x,y) = Sequence [cs x, cs y] +instance (IsYamlObject a, IsYamlObject b) => IsYamlObject (a,b) where + toYaml (x,y) = Sequence [toYaml x, toYaml y] -instance (IsYamlObject a, IsYamlObject b) => ConvertSuccess YamlObject (a,b) where - convertSuccess obj = (cs x, cs y) + fromYaml obj = (fromYaml x, fromYaml y) where list = getList obj x = tryGet list 0 y = tryGet list 1 -instance (IsYamlObject a, IsYamlObject b) => IsYamlObject (a,b) where - -instance (IsYamlObject a, IsYamlObject b, IsYamlObject c) => ConvertSuccess (a,b,c) YamlObject where - convertSuccess (x,y,z) = Sequence [cs x, cs y, cs z] +instance (IsYamlObject a, IsYamlObject b, IsYamlObject c) => IsYamlObject (a,b,c) where + toYaml (x,y,z) = Sequence [toYaml x, toYaml y, toYaml z] -instance (IsYamlObject a, IsYamlObject b, IsYamlObject c) => ConvertSuccess YamlObject (a,b,c) where - convertSuccess obj = (cs x, cs y, cs z) + fromYaml obj = (fromYaml x, fromYaml y, fromYaml z) where list = getList obj x = tryGet list 0 y = tryGet list 1 z = tryGet list 2 -instance (IsYamlObject a, IsYamlObject b, IsYamlObject c) => IsYamlObject (a,b,c) where - instance (Default a, Default b) => Default (a,b) where def = (def, def) @@ -73,52 +64,39 @@ _right = "Right" _left :: BS.ByteString _left = "Left" -instance (IsYamlObject a, IsYamlObject b) => ConvertSuccess (Either a b) YamlObject where - convertSuccess (Right a) = Mapping [(toYamlScalar _right, cs a)] - convertSuccess (Left b) = Mapping [(toYamlScalar _left, cs b)] - -instance (IsYamlObject a, IsYamlObject b) => ConvertSuccess YamlObject (Either a b) where - convertSuccess (Mapping [(name, val)]) = - if fromYamlScalar name == _right - then Right (cs val) - else if fromYamlScalar name == _left - then Left (cs val) - else def - convertSuccess _ = def - instance (Default a) => Default (Either a b) where def = Left def instance (IsYamlObject a, IsYamlObject b) => IsYamlObject (Either a b) where + toYaml (Right a) = Mapping [(toYamlScalar _right, toYaml a)] + toYaml (Left b) = Mapping [(toYamlScalar _left, toYaml b)] + + fromYaml (Mapping [(name, val)]) = + if fromYamlScalar name == _right + then Right (fromYaml val) + else if fromYamlScalar name == _left + then Left (fromYaml val) + else def + fromYaml _ = def instance Default YamlObject where def = Sequence [] instance IsYamlObject YamlObject where - -instance ConvertSuccess YamlObject Double where - convertSuccess x = fromMaybe def $ getScalar x - -instance ConvertSuccess Double YamlObject where - convertSuccess x = Scalar $ toYamlScalar x + toYaml = id + fromYaml = id instance IsYamlObject Double where - -instance ConvertSuccess YamlObject Int where - convertSuccess x = fromMaybe def $ getScalar x - -instance ConvertSuccess Int YamlObject where - convertSuccess x = Scalar $ toYamlScalar x + fromYaml x = fromMaybe def $ getScalar x + toYaml x = Scalar $ toYamlScalar x instance IsYamlObject Int where - -instance ConvertSuccess YamlObject Integer where - convertSuccess x = fromMaybe def $ getScalar x - -instance ConvertSuccess Integer YamlObject where - convertSuccess x = Scalar $ toYamlScalar x + fromYaml x = fromMaybe def $ getScalar x + toYaml x = Scalar $ toYamlScalar x instance IsYamlObject Integer where + fromYaml x = fromMaybe def $ getScalar x + toYaml x = Scalar $ toYamlScalar x instance IsYamlScalar Bool where toYamlScalar True = stringScalar "True" @@ -132,58 +110,42 @@ instance IsYamlScalar Bool where instance Default Bool where def = False -instance ConvertSuccess Bool YamlObject where - convertSuccess x = Scalar $ toYamlScalar x - -instance ConvertSuccess YamlObject Bool where - convertSuccess x = fromMaybe def $ getScalar x - instance IsYamlObject Bool where - -instance ConvertSuccess YamlObject BS.ByteString where - convertSuccess x = fromMaybe def $ getScalar x - -instance ConvertSuccess BS.ByteString YamlObject where - convertSuccess x = Scalar $ toYamlScalar x + toYaml x = Scalar $ toYamlScalar x + fromYaml x = fromMaybe def $ getScalar x instance IsYamlObject BS.ByteString where - -instance ConvertSuccess YamlObject String where - convertSuccess x = fromMaybe def $ getScalar x - -instance ConvertSuccess String YamlObject where - convertSuccess x = Scalar $ toYamlScalar x + fromYaml x = fromMaybe def $ getScalar x + toYaml x = Scalar $ toYamlScalar x instance IsYamlObject String where + fromYaml x = fromMaybe def $ getScalar x + toYaml x = Scalar $ toYamlScalar x data Call = Call { methodName :: BS.ByteString, args :: YamlObject } deriving (Show) mkCall :: BS.ByteString -> YamlObject -> YamlObject -mkCall name args = cs $ Call name args +mkCall name args = toYaml $ Call name args stringScalar :: String -> YamlScalar stringScalar = toYamlScalar -instance ConvertSuccess Call YamlObject where - convertSuccess (Call name args) = Mapping [(stringScalar "call", Scalar $ toYamlScalar name), - (stringScalar "args", args)] - -instance ConvertSuccess YamlObject Call where - convertSuccess obj = Call name args - where - name = fromMaybe "defaultMethod" $ getScalarAttr "call" obj - args = fromMaybe (Sequence []) $ getAttr "args" obj - instance Default Call where def = Call "defaultMethod" def instance IsYamlObject Call where + toYaml (Call name args) = Mapping [(stringScalar "call", Scalar $ toYamlScalar name), + (stringScalar "args", args)] + fromYaml obj = Call name args + where + name = fromMaybe "defaultMethod" $ getScalarAttr "call" obj + args = fromMaybe (Sequence []) $ getAttr "args" obj -- | Convert any (a -> IO b) action to YAML RPC method yamlMethod :: (IsYamlObject a, IsYamlObject b) => (a -> IO b) -> YamlObject -> IO YamlObject yamlMethod fn = \obj -> do - let x = cs obj + let x = fromYaml obj y <- fn x - return $ cs y + return $ toYaml y diff --git a/Test.hs b/Test.hs index 7434266..3f4e6bd 100644 --- a/Test.hs +++ b/Test.hs @@ -3,7 +3,6 @@ module Main where import Data.Object.Yaml -import Data.Convertible.Base import qualified Data.Map as M import Network.YAML diff --git a/TestCall.hs b/TestCall.hs index efbcbb9..f78260c 100644 --- a/TestCall.hs +++ b/TestCall.hs @@ -6,7 +6,6 @@ import Control.Monad import System.Environment (getArgs) import qualified Data.ByteString.Char8 as BS import Data.Object.Yaml -import Data.Convertible.Base import Network.YAML diff --git a/TestDerive.hs b/TestDerive.hs index 08578f2..ac427a0 100644 --- a/TestDerive.hs +++ b/TestDerive.hs @@ -2,7 +2,6 @@ {-# LANGUAGE OverloadedStrings #-} import Data.Default -import Data.Convertible.Base import Data.Object.Yaml import qualified Data.ByteString.Char8 as BS diff --git a/yaml-rpc.cabal b/yaml-rpc.cabal index d382692..68af2f4 100644 --- a/yaml-rpc.cabal +++ b/yaml-rpc.cabal @@ -57,7 +57,7 @@ Library -- Packages needed in order to build this package. Build-depends: yaml, data-object-yaml, network, template-haskell, bytestring, - data-object, data-default, base >= 3 && <= 5, mtl, convertible-text, + data-object, data-default, base >= 3 && <= 5, mtl, containers, random -- Modules not exported by this package. -- 1.7.2.3