SingleModule.hs

{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE KindSignatures        #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}

{-# OPTIONS_GHC -fplugin=Data.Record.Plugin.WithRDP #-}

-- | Test what happens if both plugins are used in the same module
module Test.Record.Sanity.RDP.SingleModule (tests) where

import Test.Tasty
import Test.Tasty.HUnit

import Data.Record.Plugin

{-------------------------------------------------------------------------------
  Simple field selection and override
-------------------------------------------------------------------------------}

{-# ANN type R1 largeRecord #-}
data R1 = MkR1 { r1_x :: Int, r1_y :: Bool }
  deriving (Show, Eq)

test_simple :: Assertion
test_simple = do
    assertEqual "x"     r1.r1_x $ 1
    assertEqual "y"     r1.r1_y $ True
    assertEqual "r1_x"  r1_x'   $ r1{r1_x = 2}
    assertEqual "r1_y"  r1_y'   $ r1{r1_y = False}
    assertEqual "r1_xy" r1_xy'  $ r1{r1_x = 2, r1_y = False}
  where
    r1, r1_x', r1_y', r1_xy' :: R1
    r1     = MkR1 { r1_x = 1, r1_y = True  }
    r1_x'  = MkR1 { r1_x = 2, r1_y = True  }
    r1_y'  = MkR1 { r1_x = 1, r1_y = False }
    r1_xy' = MkR1 { r1_x = 2, r1_y = False }

{-------------------------------------------------------------------------------
  Field selection and override when there are overloaded fields
-------------------------------------------------------------------------------}

{-# ANN type R2 largeRecord #-}
data R2 = MkR2 { a :: Int, b :: Bool }
  deriving (Show, Eq)

{-# ANN type R3 largeRecord #-}
data R3 = MkR3 { a :: Int, b :: Char }
  deriving (Show, Eq)

test_overloaded :: Assertion
test_overloaded = do
    assertEqual "r2.a" r2.a $ 1
    assertEqual "r2.b" r2.b $ True
    assertEqual "r3.a" r3.a $ 2
    assertEqual "r3.b" r3.b $ 'a'
    assertEqual "r2'"  r2'  $ r2{a = 2}
    assertEqual "r3'"  r3'  $ r3{b = 'b'}
  where
    r2, r2' :: R2
    r2  = MkR2 { a = 1, b = True }
    r2' = MkR2 { a = 2, b = True }

    r3 :: R3
    r3  = MkR3 { a = 2, b = 'a' }
    r3' = MkR3 { a = 2, b = 'b' }

{-------------------------------------------------------------------------------
  Nested records

  Both with and without LR.
-------------------------------------------------------------------------------}

data R4_WOutLR = MkR4_WOutLR { r4_woutLR_x :: Int, r4_woutLR_y :: R5_WOutLR }
  deriving (Show, Eq)

data R5_WOutLR = MkR5_WOutLR { r5_woutLR_x :: Char, r5_woutLR_y :: Double }
  deriving (Show, Eq)

{-# ANN type R4_WithLR largeRecord #-}
data R4_WithLR = MkR4_WithLR { r4_withLR_x :: Int, r4_withLR_y :: R5_WithLR }
  deriving (Show, Eq)

{-# ANN type R5_WithLR largeRecord #-}
data R5_WithLR = MkR5_WithLR { r5_withLR_x :: Char, r5_withLR_y :: Double }
  deriving (Show, Eq)

test_nested :: Assertion
test_nested = do
    assertEqual "r4_woutLR_x" r4_woutLR.r4_woutLR_y.r5_woutLR_x $ 'a'
    assertEqual "r4_withLR_x" r4_WithLR.r4_withLR_y.r5_withLR_x $ 'a'
  where
    r4_woutLR :: R4_WOutLR
    r4_woutLR = MkR4_WOutLR { r4_woutLR_x = 1, r4_woutLR_y = r5_woutLR }

    r5_woutLR :: R5_WOutLR
    r5_woutLR = MkR5_WOutLR { r5_woutLR_x = 'a', r5_woutLR_y = 1.2 }

    r4_WithLR :: R4_WithLR
    r4_WithLR = MkR4_WithLR { r4_withLR_x = 1, r4_withLR_y = r5_WithLR }

    r5_WithLR :: R5_WithLR
    r5_WithLR = MkR5_WithLR { r5_withLR_x = 'a', r5_withLR_y = 1.2 }

{-------------------------------------------------------------------------------
  Collect all tests
-------------------------------------------------------------------------------}

tests :: TestTree
tests = testGroup "Test.Record.Sanity.RDP" [
      testCase "simple"     test_simple
    , testCase "overloaded" test_overloaded
    , testCase "nested"     test_nested
    ]