Simplest array CRDT

abelphata.hs

-- stack --resolver=lts-23.20 script

import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck as QC
import Test.Tasty.Runners
import Test.Tasty.SmallCheck as SC

empty :: [a]
empty = []

merge :: (Ord a) => [a] -> [a] -> [a]
merge [] ys = ys
merge xs [] = xs
merge (x : xs) (y : ys) =
    case compare x y of
        LT -> x : merge xs (y : ys)
        EQ -> x : merge xs ys
        GT -> y : merge (x : xs) ys

accociativity :: (Ord a, Show a) => [a] -> [a] -> [a] -> Bool
accociativity xs ys zs =
    (xs `merge` ys) `merge` zs == xs `merge` (ys `merge` zs)

commutativity :: (Ord a, Show a) => [a] -> [a] -> Bool
commutativity xs ys = xs `merge` ys == ys `merge` xs

idempotence :: (Ord a, Show a) => [a] -> Bool
idempotence xs = xs `merge` xs == xs

identityLeft :: (Ord a, Show a) => [a] -> Bool
identityLeft xs = empty `merge` xs == xs

identityRight :: (Ord a, Show a) => [a] -> Bool
identityRight xs = xs `merge` empty == xs

main :: IO ()
main =
    defaultMain
        . localOption (NumThreads 4)
        . localOption (SmallCheckDepth 9)
        $ testGroup
            "RGA-like merge"
            [ testGroup
                "accociativity"
                [ QC.testProperty "QuickCheck" $ accociativity @Bool
                , adjustOption (min $ SmallCheckDepth 6)
                    . SC.testProperty "SmallCheck"
                    $ accociativity @Bool
                ]
            , testGroup
                "commutativity"
                [ QC.testProperty "QuickCheck" $ commutativity @Bool
                , SC.testProperty "SmallCheck" $ commutativity @Bool
                ]
            , testGroup
                "idempotence"
                [ QC.testProperty "QuickCheck" $ idempotence @Bool
                , SC.testProperty "SmallCheck" $ idempotence @Bool
                ]
            , testGroup
                "identityLeft"
                [ QC.testProperty "QuickCheck" $ identityLeft @Bool
                , SC.testProperty "SmallCheck" $ identityLeft @Bool
                ]
            , testGroup
                "identityRight"
                [ QC.testProperty "QuickCheck" $ identityRight @Bool
                , SC.testProperty "SmallCheck" $ identityRight @Bool
                ]
            , testCase "example" $ merge "alpha" "beta" @?= "abelphata"
            , testCase "example" $ merge "Miguel" "Michael" @?= "Micghaeluel"
            , testCase "example" $
                merge "Cocos Islands" "Canary Islands"
                    @?= "Canaocors Islandsy Islands"
            , testCase "example" $
                merge "United Arab Emirates" "United States of America"
                    @?= "United ASrab Emirataestes of America"
            , testCase "Rickroll by characters" $
                foldr1 merge rickroll
                    @?= "Never gonna gilemake rsat ell a lie and hun arot und \
                        \and desert ve y goodbu cdorupwnye"
            , testCase "Rickroll by words" $
                unwords (foldr1 merge $ map words rickroll)
                    @?= "Never gonna give let make run around and desert say \
                        \goodbye tell a lie and hurt you cry down up"
            ]

rickroll =
    [ "Never gonna give you up"
    , "Never gonna let you down"
    , "Never gonna run around and desert you"
    , "Never gonna say goodbye"
    , "Never gonna make you cry"
    , "Never gonna tell a lie and hurt you"
    ]