Merging.hs

{-# LANGUAGE DataKinds        #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE TypeFamilies     #-}
{-# LANGUAGE TypeOperators    #-}

{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# OPTIONS_GHC -fplugin=Data.Record.Anon.Plugin #-}

module Test.Sanity.Merging (tests) where

import Data.SOP.BasicFunctors

import Test.Tasty
import Test.Tasty.HUnit

import Data.Record.Anon
import Data.Record.Anon.Advanced (Record)
import qualified Data.Record.Anon.Advanced as Anon

tests :: TestTree
tests = testGroup "Test.Sanity.Merging" [
      testCase "concrete"     test_concrete
    , testCase "eqConstraint" test_eqConstraint
    ]

{-------------------------------------------------------------------------------
  Example values
-------------------------------------------------------------------------------}

ab, ab' ::
    Record I (Merge [ "a" := Bool   , "b" := Int  ]
                    [ "c" := Double , "d" := Char ])
ab  = Anon.merge a b
ab' = Anon.merge a' b

a, a' :: Record I [ "a" := Bool, "b" := Int ]
a =
    Anon.insert #a (I True)
  $ Anon.insert #b (I (1 :: Int))
  $ Anon.empty
a' =
    Anon.insert #a (I False)
  $ Anon.insert #b (I (1 :: Int))
  $ Anon.empty

b :: Record I [ "c" := Double, "d" := Char ]
b = Anon.insert #c (I 3.14)
  $ Anon.insert #d (I 'a')
  $ Anon.empty

{-------------------------------------------------------------------------------
  Tests proper
-------------------------------------------------------------------------------}

test_concrete :: Assertion
test_concrete = do
    assertEqual "get" (I True) $ Anon.get #a ab
    assertEqual "set" ab'      $ Anon.set #a (I False) ab

-- | Test that type equalities are handled correctly
test_eqConstraint :: Assertion
test_eqConstraint = do
    assertEqual "a" (I True) $ f1 ab
    assertEqual "b" (I 1)    $ f2 ab
    assertEqual "c" (I 3.14) $ f3 ab
  where
    -- Single simple equality
    f1 :: row ~ Merge [ "a" := Bool   , "b" := Int  ]
                      [ "c" := Double , "d" := Char ]
       => Record I row -> I Bool
    f1 = Anon.get #a

    -- Multiple (transitive) equalities
    f2 :: ( tf1 ~ tf2
          , tf2 ~ Merge
          , row ~ tf1 [ "a" := Bool   , "b" := Int  ]
                      [ "c" := Double , "d" := Char ]
          )
       => Record I row -> I Int
    f2 = Anon.get #b

    -- Equality with partial application
    f3 :: ( merge ~ Merge [ "a" := Bool   , "b" := Int  ]
          , row   ~ merge [ "c" := Double , "d" := Char ]
          )
       => Record I row -> I Double
    f3 = Anon.get #c