From c9c0d66c2dddbdcc25f6bc6df18039471591c3df Mon Sep 17 00:00:00 2001 From: Eugene Crosser Date: Sun, 13 Apr 2014 20:24:44 +0400 Subject: [PATCH] implement merge via typeclass --- NmcDom.hs | 91 +++++++++++++++++++++++++++++++++++++------------------ d/extra1 | 2 +- d/extra2 | 2 +- 3 files changed, 63 insertions(+), 32 deletions(-) diff --git a/NmcDom.hs b/NmcDom.hs index 731aa1c..fe87270 100644 --- a/NmcDom.hs +++ b/NmcDom.hs @@ -9,13 +9,35 @@ module NmcDom ( NmcDom(..) import Prelude hiding (length) import Data.ByteString.Lazy (ByteString) import qualified Data.Text as T (unpack) +import Data.List as L (union) import Data.List.Split import Data.Char -import Data.Map as M (Map, lookup, delete, size) +import Data.Map as M (Map, lookup, delete, size, union) import Data.Vector (toList,(!),length) import Control.Applicative ((<$>), (<*>), empty) import Data.Aeson +class Mergeable a where + merge :: a -> a -> a -- bias towads second arg + +instance Ord k => Mergeable (Map k a) where + merge mx my = M.union my mx + +-- instance Mergeable String where +-- merge _ b = b + +instance Mergeable Value where + merge _ b = b + +instance Mergeable a => Mergeable (Maybe a) where + merge (Just x) (Just y) = Just (merge x y) + merge Nothing (Just y) = Just y + merge (Just x) Nothing = Just x + merge Nothing Nothing = Nothing + +instance Eq a => Mergeable [a] where + merge xs ys = L.union xs ys + data NmcRRService = NmcRRService { srvName :: String , srvProto :: String @@ -37,6 +59,9 @@ instance FromJSON NmcRRService where else empty parseJSON _ = empty +instance Mergeable NmcRRService where + merge _ b = b + data NmcRRI2p = NmcRRI2p { i2pDestination :: String , i2pName :: String @@ -50,6 +75,9 @@ instance FromJSON NmcRRI2p where <*> o .: "b32" parseJSON _ = empty +instance Mergeable NmcRRI2p where + merge _ b = b + data NmcDom = NmcDom { domService :: Maybe [NmcRRService] , domIp :: Maybe [String] , domIp6 :: Maybe [String] @@ -106,37 +134,40 @@ instance FromJSON NmcDom where <*> o .:? "ds" parseJSON _ = empty +instance Mergeable NmcDom where + merge sub dom = dom { domService = mergelm domService + , domIp = mergelm domIp + , domIp6 = mergelm domIp6 + , domTor = choose domTor + , domI2p = mergelm domI2p + , domFreenet = choose domFreenet + , domAlias = choose domAlias + , domTranslate = choose domTranslate + , domEmail = choose domEmail + , domLoc = choose domLoc + , domInfo = mergelm domInfo + , domNs = mergelm domNs + , domDelegate = mergelm domDelegate + , domImport = choose domImport + , domMap = mergelm domMap + , domFingerprint = mergelm domFingerprint + , domTls = mergelm domTls + , domDs = mergelm domDs + } + where + mergelm x = merge (x sub) (x dom) +-- Because it is not possible to define instance of merge for Strings, +-- we have to treat string elements separately, otherwise strings are +-- 'unioned' along with the rest of lists. Ugly, but alternatives are worse. + choose field = case field dom of + Nothing -> field sub + Just x -> Just x + + emptyNmcDom = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing --- FIXME -- I hope there exists a better way to merge records! -mergeNmcDom :: NmcDom -> NmcDom -> NmcDom -mergeNmcDom sub dom = dom { domService = choose domService - , domIp = choose domIp - , domIp6 = choose domIp6 - , domTor = choose domTor - , domI2p = choose domI2p - , domFreenet = choose domFreenet - , domAlias = choose domAlias - , domTranslate = choose domTranslate - , domEmail = choose domEmail - , domLoc = choose domLoc - , domInfo = choose domInfo - , domNs = choose domNs - , domDelegate = choose domDelegate - , domImport = choose domImport - , domMap = choose domMap - , domFingerprint = choose domFingerprint - , domTls = choose domTls - , domDs = choose domDs - } - where - choose :: (NmcDom -> Maybe a) -> Maybe a - choose field = case field dom of - Nothing -> field sub - Just x -> Just x - -- | Perform query and return error string or parsed domain object queryNmcDom :: (String -> IO (Either String ByteString)) -- ^ query operation action @@ -168,7 +199,7 @@ mergeImport queryOp base = do sub <- queryNmcDom queryOp key case sub of Left e -> return $ Left e - Right sub' -> mergeImport queryOp $ sub' `mergeNmcDom` base' + Right sub' -> mergeImport queryOp $ sub' `merge` base' -- | If there is an element in the map with key "", merge the contents -- and remove this element. Do this recursively. @@ -186,7 +217,7 @@ mergeSelf base = Just map' -> case M.lookup "" map' of Nothing -> base' - Just sub -> (mergeSelf sub) `mergeNmcDom` base' + Just sub -> (mergeSelf sub) `merge` base' -- | Presence of some elements require removal of some others normalizeDom :: NmcDom -> NmcDom diff --git a/d/extra1 b/d/extra1 index e4f87bb..ff6c7ef 100644 --- a/d/extra1 +++ b/d/extra1 @@ -1 +1 @@ -{"service":[["imap", "tcp", 0, 0, 143, "mail.host.com."],["smtp", "tcp", 0, 0, 143, "mail.host.com."]],"import":"d/extra2","ip":["1.2.3.4"]} +{"service":[["smtp", "tcp", 0, 0, 143, "mail.host.com."]],"import":"d/extra2","ip":["1.2.3.4"],"alias":"extra1alias"} diff --git a/d/extra2 b/d/extra2 index e7428da..c899105 100644 --- a/d/extra2 +++ b/d/extra2 @@ -1 +1 @@ -{"ip":["5.6.7.8"]} +{"ip":["5.6.7.8"],"alias":"extra2alias","service":[["imap", "tcp", 0, 0, 143, "mail.host.com."]]} -- 2.39.2