implement merge via typeclass

diff --git a/NmcDom.hs b/NmcDom.hs
index 731aa1cbb1f72b279377fc95f85bc22809fc6399..fe87270c728d31a51064c35c50742ec69e8d3b48 100644 (file)
--- 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 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.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
 
 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
 data NmcRRService = NmcRRService
                         { srvName       :: String
                         , srvProto      :: String


@@ -37,6 +59,9 @@ instance FromJSON NmcRRService where
                 else empty
         parseJSON _ = empty
 
                 else empty
         parseJSON _ = empty
 

+instance Mergeable NmcRRService where
+        merge _ b = b
+

 data NmcRRI2p = NmcRRI2p
                         { i2pDestination :: String
                         , i2pName        :: String
 data NmcRRI2p = NmcRRI2p
                         { i2pDestination :: String
                         , i2pName        :: String


@@ -50,6 +75,9 @@ instance FromJSON NmcRRI2p where
                 <*> o .: "b32"
         parseJSON _ = empty
 
                 <*> o .: "b32"
         parseJSON _ = empty
 

+instance Mergeable NmcRRI2p where
+        merge _ b = b
+

 data NmcDom = NmcDom    { domService     :: Maybe [NmcRRService]
                         , domIp          :: Maybe [String]
                         , domIp6         :: Maybe [String]
 data NmcDom = NmcDom    { domService     :: Maybe [NmcRRService]
                         , domIp          :: Maybe [String]
                         , domIp6         :: Maybe [String]


@@ -106,37 +134,40 @@ instance FromJSON NmcDom where
                 <*> o .:? "ds"
         parseJSON _ = empty
 
                 <*> 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
 
 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
 -- | 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
       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.
 
 -- | 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 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
 
 -- | Presence of some elements require removal of some others
 normalizeDom :: NmcDom -> NmcDom

diff --git a/d/extra1 b/d/extra1
index e4f87bb3860cc4fedb016c34e03b72dfb6880fa5..ff6c7ef9992f8d25425db86bd47b5b5833f2fd91 100644 (file)
--- 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 e7428da6764920aba7288d8d9a5cfd2d0b4299a4..c89910506ebaa1c6a5f571d9c861b0506fa77d1c 100644 (file)
--- 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."]]}