diff --git a/Caller.hs b/Caller.hs deleted file mode 100644 index cf9924f..0000000 --- a/Caller.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module 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 - -import YAML -import YAMLInstances -import Server - -callDynamic :: (IsYamlObject a, IsYamlObject b) => (BS.ByteString -> IO (BS.ByteString,Int)) -> BS.ByteString -> BS.ByteString -> a -> IO b -callDynamic getServer service name args = do - srv <- getServer service - call srv name args - -call :: (IsYamlObject a, IsYamlObject b) => (BS.ByteString, Int) -> BS.ByteString -> a -> IO b -call (host,port) name args = withSocketsDo $ do - h <- connectTo (BS.unpack host) (PortNumber $ fromIntegral port) - let c = mkCall name (cs args) - s = serialize c - hSetBuffering h NoBuffering - BS.hPutStrLn h s - lns <- readHandle h [] - hClose h - let text = BS.unlines lns - case unserialize text of - Nothing -> fail "No answer" - Just x -> return x diff --git a/Derive.hs b/Derive.hs deleted file mode 100644 index 9af4679..0000000 --- a/Derive.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE TemplateHaskell, TypeSynonymInstances, MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -module Derive where - -import Language.Haskell.TH -import Control.Monad -import Data.Maybe -import Data.Default -import Data.Object -import Data.Object.Yaml -import qualified Data.ByteString.Char8 as BS - -import YAML -import YAMLInstances - -data T1 = T1 - -mkList :: [Name] -> Q Exp -mkList [] = [| [] |] -mkList (v:vars) = [| (toYamlScalar $(stringOfName v), Scalar $ toYamlScalar $(varE v)): $(mkList vars) |] - -getNameBase :: Name -> Name -getNameBase name = mkName $ nameBase name - -stringOfName :: Name -> ExpQ -stringOfName n = sigE (stringE $ nameBase n) [t| BS.ByteString |] - -nameE :: Name -> ExpQ -nameE name = varE $ getNameBase name - -consClause :: Con -> ClauseQ -consClause (NormalC name fields) = do - -- Name of constructor, i.e. "A". Will become string literal in generated code - let constructorName = nameBase name - - -- Get variables for left and right side of function definition - (pats,vars) <- genPE (length fields) - - clause [conP name pats] -- (A x1 x2) - (normalB [| Mapping [(toYamlScalar (BS.pack constructorName), Mapping $(mkList vars))] |]) [] - -consClause (RecC name fields) = do - -- Name of constructor, i.e. "A". Will become string literal in generated code - let constructorName = nameBase name - names = [getNameBase name | (name, _, _) <- fields] - pats = map varP names - clause [conP name pats] -- (A x1 x2) - (normalB [| Mapping [(toYamlScalar (BS.pack constructorName), Mapping $(mkList names))] |]) [] - -consClause x = report True (show x) >> return undefined - -genFromClause cName names= do - obj <- newName "obj" - let guard = [| getFirstKey $(varE obj) == (BS.pack cName) |] - body = foldl appE (conE $ mkName cName) $ map (getAttr' cName obj) $ map getNameBase names - clause [varP obj] - (guardedB [normalGE guard body]) [] - where - getAttr' c obj n = [| fromMaybe def $ getSubKey (BS.pack c) $(stringOfName n) $(varE obj) |] - -fromClause :: Con -> ClauseQ -fromClause (RecC name fields) = do - let constructorName = nameBase name - names = [getNameBase name | (name, _, _) <- fields] - genFromClause constructorName names - -fromClause (NormalC name fields) = do - let constructorName = nameBase name - (_,names) <- genPE (length fields) - genFromClause constructorName names - -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]] - -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]] - -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] - -defaultClause :: Con -> ClauseQ -defaultClause (RecC name fields) = do - let defs = replicate (length fields) (varE $ mkName "def") - body = foldl appE (conE name) defs - clause [] (normalB body) [] -defaultClause (NormalC name fields) = do - let defs = replicate (length fields) (varE $ mkName "def") - body = foldl appE (conE name) defs - clause [] (normalB body) [] - -deriveDefault :: Name -> Q [Dec] -deriveDefault t = do - TyConI (DataD _ _ _ constructors _) <- reify t - body <- defaultClause (head constructors) - return [InstanceD [] (ConT ''Default `AppT` ConT t) [FunD 'def [body]]] - --- | Generate n unique variables and return them in form of patterns and expressions -genPE :: Int -> Q ([PatQ], [Name]) -genPE n = do - ids <- replicateM n (newName "x") - return (map varP ids, ids) - diff --git a/Dispatcher.hs b/Dispatcher.hs deleted file mode 100644 index d3710ba..0000000 --- a/Dispatcher.hs +++ /dev/null @@ -1,28 +0,0 @@ - -module Dispatcher where - -import qualified Data.Map as M -import Data.Object.Yaml -import Data.Convertible.Base -import qualified Data.ByteString.Char8 as BS - -import YAML -import YAMLInstances -import Server - -type Worker = YamlObject -> IO YamlObject -type Rules = M.Map BS.ByteString Worker - -mkRules :: [(BS.ByteString,Worker)] -> Rules -mkRules pairs = M.fromList pairs - -dispatch :: Rules -> Worker -dispatch rules = \obj -> - let call :: Call - call = cs obj - in case M.lookup (methodName call) rules of - Nothing -> fail $ "Unknown method: " ++ (BS.unpack $ methodName call) - Just fn -> fn (args call) - -dispatcher :: Int -> Rules -> IO () -dispatcher port rules = server port (dispatch rules) diff --git a/Makefile b/Makefile index ff0cc76..ff050fd 100644 --- a/Makefile +++ b/Makefile @@ -1,13 +1,13 @@ -all: Test TestClient +all: Test TestCall -Test: *.hs - ghc --make Test.hs +Test: *.hs Network/YAML/*.hs + ghc -i. --make Test.hs -TestClient: *.hs - ghc --make TestClient.hs +TestCall: *.hs Network/YAML/*.hs + ghc -i. --make TestCall.hs clean: - rm -f *.hi - rm -f *.o + find . -name *.hi -delete + find . -name *.o -delete diff --git a/Network/YAML/Base.hs b/Network/YAML/Base.hs new file mode 100644 index 0000000..5edef72 --- /dev/null +++ b/Network/YAML/Base.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE FlexibleInstances, FlexibleContexts, TypeSynonymInstances, MultiParamTypeClasses, OverloadedStrings #-} + +module Network.YAML.Base where + +import Control.Monad +import Data.Maybe +import Data.Default +import Data.Object +import Data.Object.Yaml +import qualified Data.ByteString.Char8 as BS +import Text.Libyaml hiding (encode, decode) + +class (ConvertSuccess YamlObject a, ConvertSuccess a YamlObject, Default a) => IsYamlObject a where + +getAttr :: BS.ByteString -> YamlObject -> Maybe YamlObject +getAttr key (Mapping pairs) = lookup (toYamlScalar key) pairs +getAttr key (Sequence lst) = + case catMaybes $ map (getAttr key) lst of + [x] -> Just x + _ -> Nothing +getAttr key (Scalar sc) = Nothing + +getScalar :: (IsYamlScalar a) => YamlObject -> Maybe a +getScalar (Scalar x) = Just (fromYamlScalar x) +getScalar _ = Nothing + +getList :: YamlObject -> [YamlObject] +getList (Sequence lst) = lst +getList _ = [] + +getScalarAttr :: (IsYamlScalar a) => BS.ByteString -> YamlObject -> Maybe a +getScalarAttr key obj = getScalar =<< getAttr key obj + +getSubKey :: (IsYamlScalar a) => BS.ByteString -> BS.ByteString -> YamlObject -> Maybe a +getSubKey key subkey obj = do + attr <- getAttr key obj + r <- getAttr subkey attr + getScalar r + +getListAttr :: BS.ByteString -> YamlObject -> [YamlObject] +getListAttr key obj = + case getAttr key obj of + Just x -> getList x + Nothing -> [] + +getFirstKey :: YamlObject -> BS.ByteString +getFirstKey (Mapping pairs) = fromYamlScalar $ fst $ head pairs + +instance IsYamlScalar Double where + fromYamlScalar (YamlScalar v _ _) = read $ BS.unpack v + toYamlScalar x = YamlScalar (BS.pack $ show x) NoTag Any + +instance IsYamlScalar Int where + fromYamlScalar (YamlScalar v _ _) = read $ BS.unpack v + toYamlScalar x = YamlScalar (BS.pack $ show x) NoTag Any + +serialize :: IsYamlObject a => a -> BS.ByteString +serialize x = + let c :: YamlObject + c = cs x + in encode c + +unserialize :: IsYamlObject a => BS.ByteString -> Maybe a +unserialize x = + let d :: Maybe YamlObject + d = decode x + in case d of + Just y -> Just $ cs y + Nothing -> Nothing + +-- p = Point 3.0 2.0 +-- +-- main = do +-- let s = serialize p +-- BS.putStrLn s +-- let c :: YamlObject +-- c = cs p +-- p' :: Point +-- p' = cs c +-- print p' diff --git a/Network/YAML/Caller.hs b/Network/YAML/Caller.hs new file mode 100644 index 0000000..34dabfd --- /dev/null +++ b/Network/YAML/Caller.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} + +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 + +import Network.YAML.Base +import Network.YAML.Instances +import Network.YAML.Server + +callDynamic :: (IsYamlObject a, IsYamlObject b) => (BS.ByteString -> IO (BS.ByteString,Int)) -> BS.ByteString -> BS.ByteString -> a -> IO b +callDynamic getServer service name args = do + srv <- getServer service + call srv name args + +call :: (IsYamlObject a, IsYamlObject b) => (BS.ByteString, Int) -> BS.ByteString -> a -> IO b +call (host,port) name args = withSocketsDo $ do + h <- connectTo (BS.unpack host) (PortNumber $ fromIntegral port) + let c = mkCall name (cs args) + s = serialize c + hSetBuffering h NoBuffering + BS.hPutStrLn h s + lns <- readHandle h [] + hClose h + let text = BS.unlines lns + case unserialize text of + Nothing -> fail "No answer" + Just x -> return x diff --git a/Network/YAML/Derive.hs b/Network/YAML/Derive.hs new file mode 100644 index 0000000..d496a30 --- /dev/null +++ b/Network/YAML/Derive.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE TemplateHaskell, TypeSynonymInstances, MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +module Network.YAML.Derive where + +import Language.Haskell.TH +import Control.Monad +import Data.Maybe +import Data.Default +import Data.Object +import Data.Object.Yaml +import qualified Data.ByteString.Char8 as BS + +import Network.YAML.Base +import Network.YAML.Instances + +data T1 = T1 + +mkList :: [Name] -> Q Exp +mkList [] = [| [] |] +mkList (v:vars) = [| (toYamlScalar $(stringOfName v), Scalar $ toYamlScalar $(varE v)): $(mkList vars) |] + +getNameBase :: Name -> Name +getNameBase name = mkName $ nameBase name + +stringOfName :: Name -> ExpQ +stringOfName n = sigE (stringE $ nameBase n) [t| BS.ByteString |] + +nameE :: Name -> ExpQ +nameE name = varE $ getNameBase name + +consClause :: Con -> ClauseQ +consClause (NormalC name fields) = do + -- Name of constructor, i.e. "A". Will become string literal in generated code + let constructorName = nameBase name + + -- Get variables for left and right side of function definition + (pats,vars) <- genPE (length fields) + + clause [conP name pats] -- (A x1 x2) + (normalB [| Mapping [(toYamlScalar (BS.pack constructorName), Mapping $(mkList vars))] |]) [] + +consClause (RecC name fields) = do + -- Name of constructor, i.e. "A". Will become string literal in generated code + let constructorName = nameBase name + names = [getNameBase name | (name, _, _) <- fields] + pats = map varP names + clause [conP name pats] -- (A x1 x2) + (normalB [| Mapping [(toYamlScalar (BS.pack constructorName), Mapping $(mkList names))] |]) [] + +consClause x = report True (show x) >> return undefined + +genFromClause cName names= do + obj <- newName "obj" + let guard = [| getFirstKey $(varE obj) == (BS.pack cName) |] + body = foldl appE (conE $ mkName cName) $ map (getAttr' cName obj) $ map getNameBase names + clause [varP obj] + (guardedB [normalGE guard body]) [] + where + getAttr' c obj n = [| fromMaybe def $ getSubKey (BS.pack c) $(stringOfName n) $(varE obj) |] + +fromClause :: Con -> ClauseQ +fromClause (RecC name fields) = do + let constructorName = nameBase name + names = [getNameBase name | (name, _, _) <- fields] + genFromClause constructorName names + +fromClause (NormalC name fields) = do + let constructorName = nameBase name + (_,names) <- genPE (length fields) + genFromClause constructorName names + +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]] + +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]] + +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] + +defaultClause :: Con -> ClauseQ +defaultClause (RecC name fields) = do + let defs = replicate (length fields) (varE $ mkName "def") + body = foldl appE (conE name) defs + clause [] (normalB body) [] +defaultClause (NormalC name fields) = do + let defs = replicate (length fields) (varE $ mkName "def") + body = foldl appE (conE name) defs + clause [] (normalB body) [] + +deriveDefault :: Name -> Q [Dec] +deriveDefault t = do + TyConI (DataD _ _ _ constructors _) <- reify t + body <- defaultClause (head constructors) + return [InstanceD [] (ConT ''Default `AppT` ConT t) [FunD 'def [body]]] + +-- | Generate n unique variables and return them in form of patterns and expressions +genPE :: Int -> Q ([PatQ], [Name]) +genPE n = do + ids <- replicateM n (newName "x") + return (map varP ids, ids) + diff --git a/Network/YAML/Dispatcher.hs b/Network/YAML/Dispatcher.hs new file mode 100644 index 0000000..4becbb5 --- /dev/null +++ b/Network/YAML/Dispatcher.hs @@ -0,0 +1,28 @@ + +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 +import Network.YAML.Instances +import Network.YAML.Server + +type Worker = YamlObject -> IO YamlObject +type Rules = M.Map BS.ByteString Worker + +mkRules :: [(BS.ByteString,Worker)] -> Rules +mkRules pairs = M.fromList pairs + +dispatch :: Rules -> Worker +dispatch rules = \obj -> + let call :: Call + call = cs obj + in case M.lookup (methodName call) rules of + Nothing -> fail $ "Unknown method: " ++ (BS.unpack $ methodName call) + Just fn -> fn (args call) + +dispatcher :: Int -> Rules -> IO () +dispatcher port rules = server port (dispatch rules) diff --git a/Network/YAML/Instances.hs b/Network/YAML/Instances.hs new file mode 100644 index 0000000..8771753 --- /dev/null +++ b/Network/YAML/Instances.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, OverloadedStrings #-} + +module Network.YAML.Instances where + +import Data.Maybe +import Data.Default +import Data.Object +import Data.Object.Yaml +import qualified Data.ByteString.Char8 as BS + +import Network.YAML.Base + +object :: [(BS.ByteString, YamlScalar)] -> YamlObject +object pairs = Mapping [(toYamlScalar name, Scalar val) | (name,val) <- pairs] + +field :: (IsYamlScalar a) => BS.ByteString -> a -> YamlObject +field name val = Mapping [(toYamlScalar name, Scalar $ toYamlScalar val)] + +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 + +instance Default YamlObject where + def = Sequence [] + +instance IsYamlObject YamlObject where + +data Call = Call { methodName :: BS.ByteString, args :: YamlObject } + deriving (Show) + +mkCall :: BS.ByteString -> YamlObject -> YamlObject +mkCall name args = cs $ 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 + +yamlMethod :: (IsYamlObject a, IsYamlObject b) => (a -> IO b) -> YamlObject -> IO YamlObject +yamlMethod fn = \obj -> do + let x = cs obj + y <- fn x + return $ cs y + diff --git a/Network/YAML/Server.hs b/Network/YAML/Server.hs new file mode 100644 index 0000000..9a3f289 --- /dev/null +++ b/Network/YAML/Server.hs @@ -0,0 +1,53 @@ + +module Network.YAML.Server where + +import Control.Monad +import Control.Monad.State +import Control.Concurrent +import Control.Exception +import Network +import System.IO +import qualified Data.ByteString.Char8 as BS +import Data.Object.Yaml + +import Network.YAML.Base +import Network.YAML.Instances + +readHandle :: Handle -> [BS.ByteString] -> IO [BS.ByteString] +readHandle h acc = do + line <- BS.hGetLine h + let line' = if BS.null line + then line + else if (BS.last line)=='\r' + then BS.init line + else line +-- print $ "read line:"++line' + if BS.null line' + then return acc + else readHandle h (acc ++ [line']) + +server :: + Int + -> (YamlObject -> IO YamlObject) + -> IO () +server port callOut = do +-- installHandler sigPIPE Ignore Nothing + sock <- listenOn (PortNumber $ fromIntegral port) + (forever $ loop sock) `finally` sClose sock + where + loop :: Socket -> IO ThreadId + loop sock = + do (h,_nm,_port) <- accept sock + forkIO + (do + hSetBuffering h NoBuffering + lns <- readHandle h [] + let text = BS.unlines lns + case unserialize text of + Nothing -> hClose h + Just ob -> do + print ob + res <- callOut ob + BS.hPutStrLn h $ serialize res + hClose h) + diff --git a/Server.hs b/Server.hs deleted file mode 100644 index 03f7ed5..0000000 --- a/Server.hs +++ /dev/null @@ -1,55 +0,0 @@ - -module Server where - -import Control.Monad -import Control.Monad.State -import Control.Concurrent -import Control.Exception -import Network -import System.IO -import qualified Data.ByteString.Char8 as BS -import Data.Object.Yaml - -import YAML -import YAMLInstances - -(<+>) = BS.append - -readHandle :: Handle -> [BS.ByteString] -> IO [BS.ByteString] -readHandle h acc = do - line <- BS.hGetLine h - let line' = if BS.null line - then line - else if (BS.last line)=='\r' - then BS.init line - else line --- print $ "read line:"++line' - if BS.null line' - then return acc - else readHandle h (acc ++ [line']) - -server :: - Int - -> (YamlObject -> IO YamlObject) - -> IO () -server port callOut = do --- installHandler sigPIPE Ignore Nothing - sock <- listenOn (PortNumber $ fromIntegral port) - (forever $ loop sock) `finally` sClose sock - where - loop :: Socket -> IO ThreadId - loop sock = - do (h,_nm,_port) <- accept sock - forkIO - (do - hSetBuffering h NoBuffering - lns <- readHandle h [] - let text = BS.unlines lns - case unserialize text of - Nothing -> hClose h - Just ob -> do - print ob - res <- callOut ob - BS.hPutStrLn h $ serialize res - hClose h) - diff --git a/Test.hs b/Test.hs index 1a51a25..4e76087 100644 --- a/Test.hs +++ b/Test.hs @@ -4,9 +4,11 @@ import Data.Object.Yaml import Data.Convertible.Base import qualified Data.Map as M -import Dispatcher -import YAML -import YAMLInstances +import Network.YAML.Dispatcher +import Network.YAML.Base +import Network.YAML.Instances + +import TestTypes double :: Point -> IO Point double (Point x y) = return $ Point (x*2) (y*2) diff --git a/TestCall.hs b/TestCall.hs index 3d98661..1c3670b 100644 --- a/TestCall.hs +++ b/TestCall.hs @@ -3,9 +3,11 @@ import Data.Object.Yaml import Data.Convertible.Base -import YAML -import YAMLInstances -import Caller +import Network.YAML.Base +import Network.YAML.Instances +import Network.YAML.Caller + +import TestTypes getService "test" = return ("127.0.0.1", 5000) getService _ = fail "Unknown service" diff --git a/TestDerive.hs b/TestDerive.hs index 4b9e816..1af713d 100644 --- a/TestDerive.hs +++ b/TestDerive.hs @@ -6,8 +6,8 @@ import Data.Convertible.Base import Data.Object.Yaml import qualified Data.ByteString.Char8 as BS -import YAML -import Derive +import Network.YAML.Base +import Network.YAML.Derive data Test = Test {getX :: Int, getY :: Int} | Another {getA :: Double} diff --git a/TestTypes.hs b/TestTypes.hs new file mode 100644 index 0000000..3d138f0 --- /dev/null +++ b/TestTypes.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell, TypeSynonymInstances, MultiParamTypeClasses #-} +module TestTypes where + +import Data.Default + +import Network.YAML.Derive + +data Point = Point { x :: Double, y :: Double } + deriving (Show) + +$(deriveDefault ''Point) + +$(deriveIsYamlObject ''Point) + diff --git a/YAML.hs b/YAML.hs deleted file mode 100644 index 4e26d2e..0000000 --- a/YAML.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE FlexibleInstances, FlexibleContexts, TypeSynonymInstances, MultiParamTypeClasses, OverloadedStrings #-} - -module YAML where - -import Control.Monad -import Data.Maybe -import Data.Default -import Data.Object -import Data.Object.Yaml -import qualified Data.ByteString.Char8 as BS -import Text.Libyaml hiding (encode, decode) - -class (ConvertSuccess YamlObject a, ConvertSuccess a YamlObject, Default a) => IsYamlObject a where - -getAttr :: BS.ByteString -> YamlObject -> Maybe YamlObject -getAttr key (Mapping pairs) = lookup (toYamlScalar key) pairs -getAttr key (Sequence lst) = - case catMaybes $ map (getAttr key) lst of - [x] -> Just x - _ -> Nothing -getAttr key (Scalar sc) = Nothing - -getScalar :: (IsYamlScalar a) => YamlObject -> Maybe a -getScalar (Scalar x) = Just (fromYamlScalar x) -getScalar _ = Nothing - -getList :: YamlObject -> [YamlObject] -getList (Sequence lst) = lst -getList _ = [] - -getScalarAttr :: (IsYamlScalar a) => BS.ByteString -> YamlObject -> Maybe a -getScalarAttr key obj = getScalar =<< getAttr key obj - -getSubKey :: (IsYamlScalar a) => BS.ByteString -> BS.ByteString -> YamlObject -> Maybe a -getSubKey key subkey obj = do - attr <- getAttr key obj - r <- getAttr subkey attr - getScalar r - -getListAttr :: BS.ByteString -> YamlObject -> [YamlObject] -getListAttr key obj = - case getAttr key obj of - Just x -> getList x - Nothing -> [] - -getFirstKey :: YamlObject -> BS.ByteString -getFirstKey (Mapping pairs) = fromYamlScalar $ fst $ head pairs - -instance IsYamlScalar Double where - fromYamlScalar (YamlScalar v _ _) = read $ BS.unpack v - toYamlScalar x = YamlScalar (BS.pack $ show x) NoTag Any - -instance IsYamlScalar Int where - fromYamlScalar (YamlScalar v _ _) = read $ BS.unpack v - toYamlScalar x = YamlScalar (BS.pack $ show x) NoTag Any - -serialize :: IsYamlObject a => a -> BS.ByteString -serialize x = - let c :: YamlObject - c = cs x - in encode c - -unserialize :: IsYamlObject a => BS.ByteString -> Maybe a -unserialize x = - let d :: Maybe YamlObject - d = decode x - in case d of - Just y -> Just $ cs y - Nothing -> Nothing - --- p = Point 3.0 2.0 --- --- main = do --- let s = serialize p --- BS.putStrLn s --- let c :: YamlObject --- c = cs p --- p' :: Point --- p' = cs c --- print p' diff --git a/YAMLInstances.hs b/YAMLInstances.hs deleted file mode 100644 index 745fc39..0000000 --- a/YAMLInstances.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, OverloadedStrings #-} - -module YAMLInstances where - -import Data.Maybe -import Data.Default -import Data.Object -import Data.Object.Yaml -import qualified Data.ByteString.Char8 as BS - -import YAML - -data Point = Point { x :: Double, y :: Double } - deriving (Show) - -object :: [(BS.ByteString, YamlScalar)] -> YamlObject -object pairs = Mapping [(toYamlScalar name, Scalar val) | (name,val) <- pairs] - -field :: (IsYamlScalar a) => BS.ByteString -> a -> YamlObject -field name val = Mapping [(toYamlScalar name, Scalar $ toYamlScalar val)] - -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 - -instance ConvertSuccess Point YamlObject where - convertSuccess (Point x y) = object [("x", toYamlScalar x), - ("y", toYamlScalar y)] - -instance ConvertSuccess YamlObject Point where - convertSuccess obj = Point x y - where - x = fromMaybe 0 $ getScalarAttr "x" obj - y = fromMaybe 0 $ getScalarAttr "y" obj - -instance Default Point where - def = Point 0 0 - -instance IsYamlObject Point where - -instance Default YamlObject where - def = Sequence [] - -instance IsYamlObject YamlObject where - -data Call = Call { methodName :: BS.ByteString, args :: YamlObject } - deriving (Show) - -mkCall :: BS.ByteString -> YamlObject -> YamlObject -mkCall name args = cs $ 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 - -yamlMethod :: (IsYamlObject a, IsYamlObject b) => (a -> IO b) -> YamlObject -> IO YamlObject -yamlMethod fn = \obj -> do - let x = cs obj - y <- fn x - return $ cs y -